diff --git a/src/racket/gc2/Makefile.in b/src/racket/gc2/Makefile.in index 666eaa1379..25c465d71d 100644 --- a/src/racket/gc2/Makefile.in +++ b/src/racket/gc2/Makefile.in @@ -45,6 +45,8 @@ OBJS = salloc.@LTO@ \ bool.@LTO@ \ builtin.@LTO@ \ char.@LTO@ \ + compenv.@LTO@ \ + compile.@LTO@ \ complex.@LTO@ \ dynext.@LTO@ \ env.@LTO@ \ @@ -60,9 +62,11 @@ OBJS = salloc.@LTO@ \ jitcall.@LTO@ \ jitcommon.@LTO@ \ jitinline.@LTO@ \ + jitprep.@LTO@ \ jitstack.@LTO@ \ jitstate.@LTO@ \ list.@LTO@ \ + marshal.@LTO@ \ module.@LTO@ \ mzrt.@LTO@ \ network.@LTO@ \ @@ -70,22 +74,25 @@ OBJS = salloc.@LTO@ \ number.@LTO@ \ numcomp.@LTO@ \ numstr.@LTO@ \ - places.@LTO@ \ + optimize.@LTO@ \ + place.@LTO@ \ port.@LTO@ \ portfun.@LTO@ \ print.@LTO@ \ rational.@LTO@ \ read.@LTO@ \ regexp.@LTO@ \ + resolve.@LTO@ \ sema.@LTO@ \ setjmpup.@LTO@ \ + sfs.@LTO@ \ string.@LTO@ \ struct.@LTO@ \ - stxobj.@LTO@ \ symbol.@LTO@ \ syntax.@LTO@ \ thread.@LTO@ \ type.@LTO@ \ + validate.@LTO@ \ vector.@LTO@ \ $(@FOREIGN_IF_USED@_OBJ) @@ -97,6 +104,8 @@ XSRCS = $(XSRCDIR)/salloc.c \ $(XSRCDIR)/bool.c \ $(XSRCDIR)/builtin.c \ $(XSRCDIR)/char.c \ + $(XSRCDIR)/compenv.c \ + $(XSRCDIR)/compile.c \ $(XSRCDIR)/complex.c \ $(XSRCDIR)/dynext.c \ $(XSRCDIR)/env.c \ @@ -112,31 +121,36 @@ XSRCS = $(XSRCDIR)/salloc.c \ $(XSRCDIR)/jitcall.c \ $(XSRCDIR)/jitcommon.c \ $(XSRCDIR)/jitinline.c \ + $(XSRCDIR)/jitprep.c \ $(XSRCDIR)/jitstack.c \ $(XSRCDIR)/jitstate.c \ $(XSRCDIR)/list.c \ + $(XSRCDIR)/marshal.c \ $(XSRCDIR)/module.c \ $(XSRCDIR)/network.c \ $(XSRCDIR)/numarith.c \ $(XSRCDIR)/numcomp.c \ $(XSRCDIR)/number.c \ $(XSRCDIR)/numstr.c \ - $(XSRCDIR)/places.c \ + $(XSRCDIR)/optimize.c \ + $(XSRCDIR)/place.c \ $(XSRCDIR)/port.c \ $(XSRCDIR)/portfun.c \ $(XSRCDIR)/print.c \ $(XSRCDIR)/rational.c \ $(XSRCDIR)/read.c \ $(XSRCDIR)/regexp.c \ + $(XSRCDIR)/resolve.c \ $(XSRCDIR)/sema.c \ $(XSRCDIR)/setjmpup.c \ + $(XSRCDIR)/sfs.c \ $(XSRCDIR)/string.c \ $(XSRCDIR)/struct.c \ - $(XSRCDIR)/stxobj.c \ $(XSRCDIR)/symbol.c \ $(XSRCDIR)/syntax.c \ $(XSRCDIR)/thread.c \ $(XSRCDIR)/type.c \ + $(XSRCDIR)/validate.c \ $(XSRCDIR)/vector.c \ $(@FOREIGN_IFUSED@_C) \ $(XSRCDIR)/main.c @@ -183,6 +197,10 @@ $(XSRCDIR)/builtin.c: ../src/builtin.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/builtin.c $(SRCDIR)/builtin.c $(XSRCDIR)/char.c: ../src/char.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/char.c $(SRCDIR)/char.c +$(XSRCDIR)/compenv.c: ../src/compenv.@LTO@ $(XFORMDEP) + $(XFORM) $(XSRCDIR)/compenv.c $(SRCDIR)/compenv.c +$(XSRCDIR)/compile.c: ../src/compile.@LTO@ $(XFORMDEP) + $(XFORM) $(XSRCDIR)/compile.c $(SRCDIR)/compile.c $(XSRCDIR)/complex.c: ../src/complex.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/complex.c $(SRCDIR)/complex.c $(XSRCDIR)/dynext.c: ../src/dynext.@LTO@ $(XFORMDEP) @@ -213,10 +231,14 @@ $(XSRCDIR)/jitcommon.c: ../src/jitcommon.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP) $(XFORM) $(XSRCDIR)/jitcommon.c $(SRCDIR)/jitcommon.c $(XSRCDIR)/jitinline.c: ../src/jitinline.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP) $(XFORM) $(XSRCDIR)/jitinline.c $(SRCDIR)/jitinline.c +$(XSRCDIR)/jitprep.c: ../src/jitprep.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP) + $(XFORM) $(XSRCDIR)/jitprep.c $(SRCDIR)/jitprep.c $(XSRCDIR)/jitstack.c: ../src/jitstack.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP) $(XFORM) $(XSRCDIR)/jitstack.c $(SRCDIR)/jitstack.c $(XSRCDIR)/jitstate.c: ../src/jitstate.@LTO@ $(XFORMDEP) $(LIGHTNINGDEP) $(XFORM) $(XSRCDIR)/jitstate.c $(SRCDIR)/jitstate.c +$(XSRCDIR)/marshal.c: ../src/marshal.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h + $(XFORM) $(XSRCDIR)/marshal.c $(SRCDIR)/marshal.c $(XSRCDIR)/module.c: ../src/module.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h $(XFORM) $(XSRCDIR)/module.c $(SRCDIR)/module.c $(XSRCDIR)/list.c: ../src/list.@LTO@ $(XFORMDEP) @@ -231,8 +253,10 @@ $(XSRCDIR)/numcomp.c: ../src/numcomp.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/numcomp.c $(SRCDIR)/numcomp.c $(XSRCDIR)/numstr.c: ../src/numstr.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/numstr.c $(SRCDIR)/numstr.c -$(XSRCDIR)/places.c: ../src/places.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h - $(XFORM) $(XSRCDIR)/places.c $(SRCDIR)/places.c +$(XSRCDIR)/optimize.c: ../src/optimize.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h + $(XFORM) $(XSRCDIR)/optimize.c $(SRCDIR)/optimize.c +$(XSRCDIR)/place.c: ../src/place.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h + $(XFORM) $(XSRCDIR)/place.c $(SRCDIR)/place.c $(XSRCDIR)/port.c: ../src/port.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/port.c $(SRCDIR)/port.c $(XSRCDIR)/portfun.c: ../src/portfun.@LTO@ $(XFORMDEP) @@ -245,16 +269,18 @@ $(XSRCDIR)/read.c: ../src/read.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/read.c $(SRCDIR)/read.c $(XSRCDIR)/regexp.c: ../src/regexp.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/regexp.c $(SRCDIR)/regexp.c +$(XSRCDIR)/resolve.c: ../src/resolve.@LTO@ $(XFORMDEP) + $(XFORM) $(XSRCDIR)/resolve.c $(SRCDIR)/resolve.c $(XSRCDIR)/sema.c: ../src/sema.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/sema.c $(SRCDIR)/sema.c $(XSRCDIR)/setjmpup.c: ../src/setjmpup.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/setjmpup.c $(SRCDIR)/setjmpup.c +$(XSRCDIR)/sfs.c: ../src/sfs.@LTO@ $(XFORMDEP) + $(XFORM) $(XSRCDIR)/sfs.c $(SRCDIR)/sfs.c $(XSRCDIR)/string.c: ../src/string.@LTO@ $(XFORMDEP) $(XFORM_SETUP) --cpp "$(CPP) -I../src $(CPPFLAGS)" -o $(XSRCDIR)/string.c $(SRCDIR)/string.c $(XSRCDIR)/struct.c: ../src/struct.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/struct.c $(SRCDIR)/struct.c -$(XSRCDIR)/stxobj.c: ../src/stxobj.@LTO@ $(XFORMDEP) - $(XFORM) $(XSRCDIR)/stxobj.c $(SRCDIR)/stxobj.c $(XSRCDIR)/symbol.c: ../src/symbol.@LTO@ $(XFORMDEP) $(SRCDIR)/mzrt.h $(XFORM) $(XSRCDIR)/symbol.c $(SRCDIR)/symbol.c $(XSRCDIR)/syntax.c: ../src/syntax.@LTO@ $(XFORMDEP) @@ -263,6 +289,8 @@ $(XSRCDIR)/thread.c: ../src/thread.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/thread.c $(SRCDIR)/thread.c $(XSRCDIR)/type.c: ../src/type.@LTO@ $(XFORMDEP) $(MZCLPFDEP) $(XFORM) $(XSRCDIR)/type.c $(SRCDIR)/type.c +$(XSRCDIR)/validate.c: ../src/validate.@LTO@ $(XFORMDEP) + $(XFORM) $(XSRCDIR)/validate.c $(SRCDIR)/validate.c $(XSRCDIR)/vector.c: ../src/vector.@LTO@ $(XFORMDEP) $(XFORM) $(XSRCDIR)/vector.c $(SRCDIR)/vector.c $(XSRCDIR)/foreign.c: ../../foreign/foreign.@LTO@ $(XFORMDEP) @@ -280,6 +308,10 @@ builtin.@LTO@: $(XSRCDIR)/builtin.c $(CC) $(CFLAGS) -c $(XSRCDIR)/builtin.c -o builtin.@LTO@ char.@LTO@: $(XSRCDIR)/char.c $(CC) $(CFLAGS) -c $(XSRCDIR)/char.c -o char.@LTO@ +compenv.@LTO@: $(XSRCDIR)/compenv.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/compenv.c -o compenv.@LTO@ +compile.@LTO@: $(XSRCDIR)/compile.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/compile.c -o compile.@LTO@ complex.@LTO@: $(XSRCDIR)/complex.c $(CC) $(CFLAGS) -c $(XSRCDIR)/complex.c -o complex.@LTO@ dynext.@LTO@: $(XSRCDIR)/dynext.c @@ -310,12 +342,16 @@ jitcommon.@LTO@: $(XSRCDIR)/jitcommon.c $(CC) $(CFLAGS) -c $(XSRCDIR)/jitcommon.c -o jitcommon.@LTO@ jitinline.@LTO@: $(XSRCDIR)/jitinline.c $(CC) $(CFLAGS) -c $(XSRCDIR)/jitinline.c -o jitinline.@LTO@ +jitprep.@LTO@: $(XSRCDIR)/jitprep.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/jitprep.c -o jitprep.@LTO@ jitstack.@LTO@: $(XSRCDIR)/jitstack.c $(CC) $(CFLAGS) -c $(XSRCDIR)/jitstack.c -o jitstack.@LTO@ jitstate.@LTO@: $(XSRCDIR)/jitstate.c $(CC) $(CFLAGS) -c $(XSRCDIR)/jitstate.c -o jitstate.@LTO@ list.@LTO@: $(XSRCDIR)/list.c $(CC) $(CFLAGS) -c $(XSRCDIR)/list.c -o list.@LTO@ +marshal.@LTO@: $(XSRCDIR)/marshal.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/marshal.c -o marshal.@LTO@ module.@LTO@: $(XSRCDIR)/module.c $(CC) $(CFLAGS) -c $(XSRCDIR)/module.c -o module.@LTO@ mzrt.@LTO@: $(SRCDIR)/mzrt.c $(SRCDIR)/mzrt.h $(XFORMDEP) @@ -330,8 +366,10 @@ numcomp.@LTO@: $(XSRCDIR)/numcomp.c $(CC) $(CFLAGS) -c $(XSRCDIR)/numcomp.c -o numcomp.@LTO@ numstr.@LTO@: $(XSRCDIR)/numstr.c $(CC) $(CFLAGS) -c $(XSRCDIR)/numstr.c -o numstr.@LTO@ -places.@LTO@: $(XSRCDIR)/places.c - $(CC) $(CFLAGS) -c $(XSRCDIR)/places.c -o places.@LTO@ +optimize.@LTO@: $(XSRCDIR)/optimize.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/optimize.c -o optimize.@LTO@ +place.@LTO@: $(XSRCDIR)/place.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/place.c -o place.@LTO@ port.@LTO@: $(XSRCDIR)/port.c $(CC) $(CFLAGS) -c $(XSRCDIR)/port.c -o port.@LTO@ portfun.@LTO@: $(XSRCDIR)/portfun.c @@ -344,16 +382,18 @@ read.@LTO@: $(XSRCDIR)/read.c $(CC) $(CFLAGS) -c $(XSRCDIR)/read.c -o read.@LTO@ regexp.@LTO@: $(XSRCDIR)/regexp.c $(CC) $(CFLAGS) -c $(XSRCDIR)/regexp.c -o regexp.@LTO@ +resolve.@LTO@: $(XSRCDIR)/resolve.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/resolve.c -o resolve.@LTO@ sema.@LTO@: $(XSRCDIR)/sema.c $(CC) $(CFLAGS) -c $(XSRCDIR)/sema.c -o sema.@LTO@ setjmpup.@LTO@: $(XSRCDIR)/setjmpup.c $(CC) $(CFLAGS) -c $(XSRCDIR)/setjmpup.c -o setjmpup.@LTO@ +sfs.@LTO@: $(XSRCDIR)/sfs.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/sfs.c -o sfs.@LTO@ string.@LTO@: $(XSRCDIR)/string.c $(CC) $(CFLAGS) -c $(XSRCDIR)/string.c -o string.@LTO@ struct.@LTO@: $(XSRCDIR)/struct.c $(CC) $(CFLAGS) -c $(XSRCDIR)/struct.c -o struct.@LTO@ -stxobj.@LTO@: $(XSRCDIR)/stxobj.c - $(CC) $(CFLAGS) -c $(XSRCDIR)/stxobj.c -o stxobj.@LTO@ symbol.@LTO@: $(XSRCDIR)/symbol.c $(CC) $(CFLAGS) -c $(XSRCDIR)/symbol.c -o symbol.@LTO@ syntax.@LTO@: $(XSRCDIR)/syntax.c @@ -362,6 +402,8 @@ thread.@LTO@: $(XSRCDIR)/thread.c $(CC) $(CFLAGS) -c $(XSRCDIR)/thread.c -o thread.@LTO@ type.@LTO@: $(XSRCDIR)/type.c $(CC) $(CFLAGS) -c $(XSRCDIR)/type.c -o type.@LTO@ +validate.@LTO@: $(XSRCDIR)/validate.c + $(CC) $(CFLAGS) -c $(XSRCDIR)/validate.c -o validate.@LTO@ vector.@LTO@: $(XSRCDIR)/vector.c $(CC) $(CFLAGS) -c $(XSRCDIR)/vector.c -o vector.@LTO@ foreign.@LTO@: $(XSRCDIR)/foreign.c diff --git a/src/racket/src/Makefile.in b/src/racket/src/Makefile.in index c90dc37421..9afb25f36c 100644 --- a/src/racket/src/Makefile.in +++ b/src/racket/src/Makefile.in @@ -16,6 +16,8 @@ OBJS = salloc.@LTO@ \ bool.@LTO@ \ builtin.@LTO@ \ char.@LTO@ \ + compenv.@LTO@ \ + compile.@LTO@ \ complex.@LTO@ \ dynext.@LTO@ \ env.@LTO@ \ @@ -32,9 +34,11 @@ OBJS = salloc.@LTO@ \ jitcall.@LTO@ \ jitcommon.@LTO@ \ jitinline.@LTO@ \ + jitprep.@LTO@ \ jitstack.@LTO@ \ jitstate.@LTO@ \ list.@LTO@ \ + marshal.@LTO@ \ module.@LTO@ \ mzrt.@LTO@ \ network.@LTO@ \ @@ -42,23 +46,26 @@ OBJS = salloc.@LTO@ \ number.@LTO@ \ numcomp.@LTO@ \ numstr.@LTO@ \ - places.@LTO@ \ + optimize.@LTO@ \ + place.@LTO@ \ port.@LTO@ \ portfun.@LTO@ \ print.@LTO@ \ rational.@LTO@ \ read.@LTO@ \ regexp.@LTO@ \ + resolve.@LTO@ \ sema.@LTO@ \ setjmpup.@LTO@ \ + sfs.@LTO@ \ string.@LTO@ \ struct.@LTO@ \ - stxobj.@LTO@ \ symbol.@LTO@ \ syntax.@LTO@ \ thread.@LTO@ \ type.@LTO@ \ unwind.@LTO@ \ + validate.@LTO@ \ vector.@LTO@ @EXTRA_GMP_OBJ@ SRCS = $(srcdir)/salloc.c \ @@ -66,6 +73,8 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/bool.c \ $(srcdir)/builtin.c \ $(srcdir)/char.c \ + $(srcdir)/compenv.c \ + $(srcdir)/compile.c \ $(srcdir)/complex.c \ $(srcdir)/dynext.c \ $(srcdir)/env.c \ @@ -82,9 +91,11 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/jitcall.c \ $(srcdir)/jitcommon.c \ $(srcdir)/jitinline.c \ + $(srcdir)/jitprep.c \ $(srcdir)/jitstack.c \ $(srcdir)/jitstate.c \ $(srcdir)/list.c \ + $(srcdir)/marshal.c \ $(srcdir)/module.c \ $(srcdir)/mzrt.c \ $(srcdir)/network.c \ @@ -92,23 +103,26 @@ SRCS = $(srcdir)/salloc.c \ $(srcdir)/number.c \ $(srcdir)/numcomp.c \ $(srcdir)/numstr.c \ - $(srcdir)/places.c \ + $(srcdir)/optimize.c \ + $(srcdir)/place.c \ $(srcdir)/port.c \ $(srcdir)/portfun.c \ $(srcdir)/print.c \ $(srcdir)/rational.c \ $(srcdir)/read.c \ $(srcdir)/regexp.c \ + $(srcdir)/resolve.c \ $(srcdir)/sema.c \ $(srcdir)/setjmpup.c \ + $(srcdir)/sfs.c \ $(srcdir)/string.c \ $(srcdir)/struct.c \ - $(srcdir)/stxobj.c \ $(srcdir)/symbol.c \ $(srcdir)/syntax.c \ $(srcdir)/thread.c \ $(srcdir)/type.c \ $(srcdir)/unwind/libunwind.c \ + $(srcdir)/validate.c \ $(srcdir)/vector.c wrong: @@ -167,6 +181,10 @@ builtin.@LTO@: $(srcdir)/builtin.c $(CC) $(CFLAGS) -c $(srcdir)/builtin.c -o builtin.@LTO@ char.@LTO@: $(srcdir)/char.c $(CC) $(CFLAGS) -c $(srcdir)/char.c -o char.@LTO@ +compenv.@LTO@: $(srcdir)/compenv.c + $(CC) $(CFLAGS) -c $(srcdir)/compenv.c -o compenv.@LTO@ +compile.@LTO@: $(srcdir)/compile.c + $(CC) $(CFLAGS) -c $(srcdir)/compile.c -o compile.@LTO@ complex.@LTO@: $(srcdir)/complex.c $(CC) $(CFLAGS) -c $(srcdir)/complex.c -o complex.@LTO@ dynext.@LTO@: $(srcdir)/dynext.c @@ -199,12 +217,16 @@ jitcommon.@LTO@: $(srcdir)/jitcommon.c $(CC) $(CFLAGS) -c $(srcdir)/jitcommon.c -o jitcommon.@LTO@ jitinline.@LTO@: $(srcdir)/jitinline.c $(CC) $(CFLAGS) -c $(srcdir)/jitinline.c -o jitinline.@LTO@ +jitprep.@LTO@: $(srcdir)/jitprep.c + $(CC) $(CFLAGS) -c $(srcdir)/jitprep.c -o jitprep.@LTO@ jitstack.@LTO@: $(srcdir)/jitstack.c $(CC) $(CFLAGS) -c $(srcdir)/jitstack.c -o jitstack.@LTO@ jitstate.@LTO@: $(srcdir)/jitstate.c $(CC) $(CFLAGS) -c $(srcdir)/jitstate.c -o jitstate.@LTO@ list.@LTO@: $(srcdir)/list.c $(CC) $(CFLAGS) -c $(srcdir)/list.c -o list.@LTO@ +marshal.@LTO@: $(srcdir)/marshal.c + $(CC) $(CFLAGS) -c $(srcdir)/marshal.c -o marshal.@LTO@ module.@LTO@: $(srcdir)/module.c $(CC) $(CFLAGS) -c $(srcdir)/module.c -o module.@LTO@ mzrt.@LTO@: $(srcdir)/mzrt.c @@ -219,8 +241,10 @@ numcomp.@LTO@: $(srcdir)/numcomp.c $(CC) $(CFLAGS) -c $(srcdir)/numcomp.c -o numcomp.@LTO@ numstr.@LTO@: $(srcdir)/numstr.c $(CC) $(CFLAGS) -c $(srcdir)/numstr.c -o numstr.@LTO@ -places.@LTO@: $(srcdir)/places.c - $(CC) $(CFLAGS) -c $(srcdir)/places.c -o places.@LTO@ +optimize.@LTO@: $(srcdir)/optimize.c + $(CC) $(CFLAGS) -c $(srcdir)/optimize.c -o optimize.@LTO@ +place.@LTO@: $(srcdir)/place.c + $(CC) $(CFLAGS) -c $(srcdir)/place.c -o place.@LTO@ port.@LTO@: $(srcdir)/port.c $(CC) $(CFLAGS) -c $(srcdir)/port.c -o port.@LTO@ portfun.@LTO@: $(srcdir)/portfun.c @@ -233,16 +257,18 @@ read.@LTO@: $(srcdir)/read.c $(CC) $(CFLAGS) -c $(srcdir)/read.c -o read.@LTO@ regexp.@LTO@: $(srcdir)/regexp.c $(CC) $(CFLAGS) -c $(srcdir)/regexp.c -o regexp.@LTO@ +resolve.@LTO@: $(srcdir)/resolve.c + $(CC) $(CFLAGS) -c $(srcdir)/resolve.c -o resolve.@LTO@ sema.@LTO@: $(srcdir)/sema.c $(CC) $(CFLAGS) -c $(srcdir)/sema.c -o sema.@LTO@ setjmpup.@LTO@: $(srcdir)/setjmpup.c $(CC) $(CFLAGS) -c $(srcdir)/setjmpup.c -o setjmpup.@LTO@ +sfs.@LTO@: $(srcdir)/sfs.c + $(CC) $(CFLAGS) -c $(srcdir)/sfs.c -o sfs.@LTO@ string.@LTO@: $(srcdir)/string.c $(CC) $(CFLAGS) -c $(srcdir)/string.c -I. -o string.@LTO@ struct.@LTO@: $(srcdir)/struct.c $(CC) $(CFLAGS) -c $(srcdir)/struct.c -o struct.@LTO@ -stxobj.@LTO@: $(srcdir)/stxobj.c - $(CC) $(CFLAGS) -c $(srcdir)/stxobj.c -o stxobj.@LTO@ symbol.@LTO@: $(srcdir)/symbol.c $(CC) $(CFLAGS) -c $(srcdir)/symbol.c -o symbol.@LTO@ syntax.@LTO@: $(srcdir)/syntax.c @@ -253,6 +279,8 @@ type.@LTO@: $(srcdir)/type.c $(CC) $(CFLAGS) -c $(srcdir)/type.c -o type.@LTO@ unwind.@LTO@: $(srcdir)/unwind/libunwind.c $(srcdir)/unwind/libunwind.h $(srcdir)/unwind/libunwind_i.h $(CC) $(CFLAGS) -c $(srcdir)/unwind/libunwind.c -o unwind.@LTO@ +validate.@LTO@: $(srcdir)/validate.c + $(CC) $(CFLAGS) -c $(srcdir)/validate.c -o validate.@LTO@ vector.@LTO@: $(srcdir)/vector.c $(CC) $(CFLAGS) -c $(srcdir)/vector.c -o vector.@LTO@ @@ -287,6 +315,10 @@ builtin.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schminc.h $(srcdir)/startup.inc $(srcdir)/cstartup.inc char.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schuchar.inc +compenv.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c +compile.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h complex.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h dynext.@LTO@: $(COMMON_HEADERS) \ @@ -316,10 +348,14 @@ jitarith.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) jitcall.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) jitcommon.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) jitinline.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) +jitprep.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h jitstack.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) $(srcdir)/codetab.inc jitstate.@LTO@: $(COMMON_HEADERS) $(JIT_HEADERS) list.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h +marshal.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h module.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c mzrt.@LTO@: $(COMMON_HEADERS) @@ -333,7 +369,9 @@ numcomp.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/nummacs.h numstr.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/random.inc $(srcdir)/newrandom.inc -places.@LTO@: $(COMMON_HEADERS) \ +optimize.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c +place.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c port.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c @@ -350,22 +388,26 @@ read.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c regexp.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c $(srcdir)/schrx.h +resolve.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c setjmpup.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schmach.h +sfs.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c string.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schvers.h $(srcdir)/mzmark.c $(srcdir)/strops.inc \ $(srcdir)/schustr.inc struct.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c -stxobj.@LTO@: $(COMMON_HEADERS) \ +syntax.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/schfd.h $(srcdir)/mzmark.c symbol.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h -syntax.@LTO@: $(COMMON_HEADERS) \ - $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c sema.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c type.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h $(srcdir)/mzmark.c vector.@LTO@: $(COMMON_HEADERS) \ $(srcdir)/../src/stypes.h +vadliate.@LTO@: $(COMMON_HEADERS) \ + $(srcdir)/../src/stypes.h diff --git a/src/racket/src/compenv.c b/src/racket/src/compenv.c new file mode 100644 index 0000000000..c5918c068b --- /dev/null +++ b/src/racket/src/compenv.c @@ -0,0 +1,2462 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" +#include "schexpobs.h" + +#define TABLE_CACHE_MAX_SIZE 2048 + +READ_ONLY static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1]; +READ_ONLY static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1]; + +READ_ONLY static Scheme_Object *unshadowable_symbol; + +/* If locked, these are probably sharable: */ +THREAD_LOCAL_DECL(static Scheme_Hash_Table *toplevels_ht); +THREAD_LOCAL_DECL(static Scheme_Hash_Table *locals_ht[2]); +THREAD_LOCAL_DECL(static int intdef_counter); +THREAD_LOCAL_DECL(static int builtin_ref_counter); +THREAD_LOCAL_DECL(static int env_uid_counter); + +#define ARBITRARY_USE 0x1 +#define CONSTRAINED_USE 0x2 +#define WAS_SET_BANGED 0x4 +#define ONE_ARBITRARY_USE 0x8 +/* See also SCHEME_USE_COUNT_MASK */ + +typedef struct Compile_Data { + int num_const; + Scheme_Object **const_names; + Scheme_Object **const_vals; + Scheme_Object **const_uids; + int *sealed; /* NULL => already sealed */ + int *use; + Scheme_Object *lifts; + int min_use, any_use; +} Compile_Data; + +typedef struct Scheme_Full_Comp_Env { + Scheme_Comp_Env base; + Compile_Data data; +} Scheme_Full_Comp_Env; + +static void init_compile_data(Scheme_Comp_Env *env); + +/* Precise GC WARNING: this macro produces unaligned pointers: */ +#define COMPILE_DATA(e) (&((Scheme_Full_Comp_Env *)e)->data) + +#define SCHEME_NON_SIMPLE_FRAME (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME \ + | SCHEME_FOR_STOPS | SCHEME_CAPTURE_LIFTED) + +static void init_scheme_local(); +static void init_toplevels(); + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +void scheme_init_compenv() +{ + init_scheme_local(); + init_toplevels(); + +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif +} + +/*========================================================================*/ +/* compilation info management */ +/*========================================================================*/ + +void scheme_default_compile_rec(Scheme_Compile_Info *rec, int drec) +{ +} + +void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, + Scheme_Compile_Info *dest, int n) +{ + int i; + + for (i = 0; i < n; i++) { +#ifdef MZTAG_REQUIRED + dest[i].type = scheme_rt_compile_info; +#endif + dest[i].comp = 1; + dest[i].dont_mark_local_use = src[drec].dont_mark_local_use; + dest[i].resolve_module_ids = src[drec].resolve_module_ids; + dest[i].no_module_cert = src[drec].no_module_cert; + dest[i].value_name = scheme_false; + dest[i].certs = src[drec].certs; + /* should be always NULL */ + dest[i].observer = src[drec].observer; + dest[i].pre_unwrapped = 0; + dest[i].env_already = 0; + dest[i].comp_flags = src[drec].comp_flags; + } +} + +void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, + Scheme_Expand_Info *dest, int n) +{ + int i; + + for (i = 0; i < n; i++) { +#ifdef MZTAG_REQUIRED + dest[i].type = scheme_rt_compile_info; +#endif + dest[i].comp = 0; + dest[i].depth = src[drec].depth; + dest[i].value_name = scheme_false; + dest[i].certs = src[drec].certs; + dest[i].observer = src[drec].observer; + dest[i].pre_unwrapped = 0; + dest[i].no_module_cert = src[drec].no_module_cert; + dest[i].env_already = 0; + dest[i].comp_flags = src[drec].comp_flags; + } +} + +void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec, + Scheme_Compile_Info *dest, int n) +{ + /* Nothing to do anymore, since we moved max_let_depth to resolve phase */ +} + +void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, + Scheme_Compile_Info *lam, int dlrec) +{ +#ifdef MZTAG_REQUIRED + lam[dlrec].type = scheme_rt_compile_info; +#endif + lam[dlrec].comp = 1; + lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use; + lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids; + lam[dlrec].no_module_cert = src[drec].no_module_cert; + lam[dlrec].value_name = scheme_false; + lam[dlrec].certs = src[drec].certs; + lam[dlrec].observer = src[drec].observer; + lam[dlrec].pre_unwrapped = 0; + lam[dlrec].env_already = 0; + lam[dlrec].comp_flags = src[drec].comp_flags; +} + +void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, + Scheme_Compile_Info *lam, int dlrec) +{ +} + +void scheme_compile_rec_done_local(Scheme_Compile_Info *rec, int drec) +{ + rec[drec].value_name = scheme_false; +} + +void scheme_rec_add_certs(Scheme_Compile_Expand_Info *src, int drec, Scheme_Object *stx) +{ + Scheme_Object *certs; + certs = scheme_stx_extract_certs(stx, src[drec].certs); + src[drec].certs = certs; +} + +/**********************************************************************/ +/* expansion observer */ +/**********************************************************************/ + +/* RMC + * - Defines #%expobs module + * - current-expand-observe + * - ??? (other syntax observations) + */ + +void scheme_call_expand_observe(Scheme_Object *obs, int tag, Scheme_Object *obj) +{ + if (!SCHEME_PROCP(obs)) { + scheme_signal_error("internal error: expand-observer should never be non-procedure"); + } else { + Scheme_Object *buf[2]; + buf[0] = scheme_make_integer(tag); + if (obj) { + buf[1] = obj; + } else { + buf[1] = scheme_false; + } + scheme_apply(obs, 2, buf); + } +} + +static Scheme_Object * +current_expand_observe(int argc, Scheme_Object **argv) +{ + return scheme_param_config("current-expand-observe", + scheme_make_integer(MZCONFIG_EXPAND_OBSERVE), + argc, argv, + 2, NULL, NULL, 0); +} + +/* always returns either procedure or NULL */ +Scheme_Object *scheme_get_expand_observe() +{ + Scheme_Object *obs; + obs = scheme_get_param(scheme_current_config(), + MZCONFIG_EXPAND_OBSERVE); + if (SCHEME_PROCP(obs)) { + return obs; + } else { + return NULL; + } +} + +void scheme_init_expand_observe(Scheme_Env *env) +{ + Scheme_Env *newenv; + Scheme_Object *modname; + + modname = scheme_intern_symbol("#%expobs"); + newenv = scheme_primitive_module(modname, env); + + scheme_add_global_constant + ("current-expand-observe", + scheme_register_parameter(current_expand_observe, + "current-expand-observe", + MZCONFIG_EXPAND_OBSERVE), + newenv); + scheme_finish_primitive_module(newenv); +} + +/*========================================================================*/ +/* compile-time env, constructors and simple queries */ +/*========================================================================*/ + +static void init_compile_data(Scheme_Comp_Env *env) +{ + Compile_Data *data; + int i, c, *use; + + c = env->num_bindings; + if (c) + use = MALLOC_N_ATOMIC(int, c); + else + use = NULL; + + data = COMPILE_DATA(env); + + data->use = use; + for (i = 0; i < c; i++) { + use[i] = 0; + } + + data->min_use = c; +} + +Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, + Scheme_Comp_Env *base, Scheme_Object *certs) +{ + Scheme_Comp_Env *frame; + int count; + + count = num_bindings; + + frame = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env); +#ifdef MZTAG_REQUIRED + frame->type = scheme_rt_comp_env; +#endif + + { + Scheme_Object **vals; + vals = MALLOC_N(Scheme_Object *, count); + frame->values = vals; + } + + frame->certs = certs; + frame->num_bindings = num_bindings; + frame->flags = flags | (base->flags & SCHEME_NO_RENAME); + frame->next = base; + frame->genv = base->genv; + frame->insp = base->insp; + frame->prefix = base->prefix; + frame->in_modidx = base->in_modidx; + + if (flags & SCHEME_NON_SIMPLE_FRAME) + frame->skip_depth = 0; + else if (base->next) + frame->skip_depth = base->skip_depth + 1; + else + frame->skip_depth = 0; + + init_compile_data(frame); + + return frame; +} + +Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int flags) +{ + Scheme_Comp_Env *e; + Comp_Prefix *cp; + + if (!insp) + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + + e = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env); +#ifdef MZTAG_REQUIRED + e->type = scheme_rt_comp_env; +#endif + e->num_bindings = 0; + e->next = NULL; + e->genv = genv; + e->insp = insp; + e->flags = flags; + init_compile_data(e); + + cp = MALLOC_ONE_RT(Comp_Prefix); +#ifdef MZTAG_REQUIRED + cp->type = scheme_rt_comp_prefix; +#endif + + e->prefix = cp; + + return e; +} + +Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, int flags) +{ + Scheme_Comp_Env *e; + + e = scheme_new_comp_env(genv, insp, flags); + e->prefix = NULL; + + return e; +} + +int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env) +{ + Scheme_Comp_Env *se; + + for (se = stx_env; NOT_SAME_OBJ(se, env); se = se->next) { + if (!(se->flags & SCHEME_FOR_INTDEF)) + break; + } + return SAME_OBJ(se, env); +} + +int scheme_used_ever(Scheme_Comp_Env *env, int which) +{ + Compile_Data *data = COMPILE_DATA(env); + + return !!data->use[which]; +} + +int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which) +{ + Compile_Data *data = COMPILE_DATA(env); + + return !!(data->use[which] & WAS_SET_BANGED); +} + +void +scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame) +{ + if ((index >= frame->num_bindings) || (index < 0)) + scheme_signal_error("internal error: scheme_add_binding: " + "index out of range: %d", index); + + frame->values[index] = val; + frame->skip_table = NULL; +} + +void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, + Scheme_Object *end_stmts, Scheme_Object *context_key, + Scheme_Object *requires, Scheme_Object *provides) +{ + Scheme_Lift_Capture_Proc *pp; + Scheme_Object *vec; + + pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc)); + *pp = cp; + + vec = scheme_make_vector(8, NULL); + SCHEME_VEC_ELS(vec)[0] = scheme_null; + SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp; + SCHEME_VEC_ELS(vec)[2] = data; + SCHEME_VEC_ELS(vec)[3] = end_stmts; + SCHEME_VEC_ELS(vec)[4] = context_key; + SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false); + SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */ + SCHEME_VEC_ELS(vec)[7] = provides; + + COMPILE_DATA(env)->lifts = vec; +} + +void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env) +{ + while (orig_env) { + if ((COMPILE_DATA(orig_env)->lifts) + && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(orig_env)->lifts)[5])) + break; + orig_env = orig_env->next; + } + + if (orig_env) { + Scheme_Object *vec, *p; + + p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env); + + vec = scheme_make_vector(8, NULL); + SCHEME_VEC_ELS(vec)[0] = scheme_false; + SCHEME_VEC_ELS(vec)[1] = scheme_void; + SCHEME_VEC_ELS(vec)[2] = scheme_void; + SCHEME_VEC_ELS(vec)[3] = scheme_false; + SCHEME_VEC_ELS(vec)[4] = scheme_false; + SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */ + SCHEME_VEC_ELS(vec)[6] = scheme_null; + SCHEME_VEC_ELS(vec)[7] = scheme_false; + + COMPILE_DATA(env)->lifts = vec; + } +} + +Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env) +{ + return scheme_reverse(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]); +} + +Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env) +{ + return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]; +} + +Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env) +{ + return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]; +} + +Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env) +{ + return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]; +} + +void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env) +{ + Scheme_Object **ns, **vs; + + if (cnt) { + ns = MALLOC_N(Scheme_Object *, cnt); + vs = MALLOC_N(Scheme_Object *, cnt); + + COMPILE_DATA(env)->num_const = cnt; + COMPILE_DATA(env)->const_names = ns; + COMPILE_DATA(env)->const_vals = vs; + + } +} + +void scheme_set_local_syntax(int pos, + Scheme_Object *name, Scheme_Object *val, + Scheme_Comp_Env *env) +{ + COMPILE_DATA(env)->const_names[pos] = name; + COMPILE_DATA(env)->const_vals[pos] = val; + env->skip_table = NULL; +} + +Scheme_Comp_Env * +scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Comp_Env *env, int flags, Scheme_Object *certs) +{ + Scheme_Comp_Env *frame; + int len, i, count; + + len = scheme_stx_list_length(vals); + count = len; + + frame = scheme_new_compilation_frame(count, flags, env, certs); + + for (i = 0; i < len ; i++) { + if (SCHEME_STX_SYMBOLP(vals)) + frame->values[i] = vals; + else { + Scheme_Object *a; + a = SCHEME_STX_CAR(vals); + frame->values[i] = a; + vals = SCHEME_STX_CDR(vals); + } + } + + init_compile_data(frame); + + return frame; +} + +Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env) +{ + if (scheme_is_toplevel(env) + || scheme_is_module_env(env) + || scheme_is_module_begin_env(env) + || (env->flags & SCHEME_INTDEF_FRAME)) + return scheme_new_compilation_frame(0, 0, env, NULL); + else + return env; +} + +Scheme_Comp_Env *scheme_require_renames(Scheme_Comp_Env *env) +{ + if (env->flags & SCHEME_NO_RENAME) { + env = scheme_new_compilation_frame(0, 0, env, NULL); + env->flags -= SCHEME_NO_RENAME; + } + + return env; +} + +int scheme_is_toplevel(Scheme_Comp_Env *env) +{ + return !env->next || (env->flags & SCHEME_TOPLEVEL_FRAME); +} + +int scheme_is_module_env(Scheme_Comp_Env *env) +{ + return !!(env->flags & SCHEME_MODULE_BEGIN_FRAME); /* name is backwards compared to symbol! */ +} + +int scheme_is_module_begin_env(Scheme_Comp_Env *env) +{ + return !!(env->flags & SCHEME_MODULE_FRAME); /* name is backwards compared to symbol! */ +} + +Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env) +{ + if (scheme_is_toplevel(env)) + return env; + else + return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, env, NULL); +} + +Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, int flags) +{ + Scheme_Toplevel *tl; + Scheme_Object *v, *pr; + + /* Important: non-resolved can't be cached, because the ISCONST + field is modified to track mutated module-level variables. But + the value for a specific toplevel is cached in the environment + layer. */ + + if (resolved) { + if ((depth < MAX_CONST_TOPLEVEL_DEPTH) + && (position < MAX_CONST_TOPLEVEL_POS)) + return toplevels[depth][position][flags]; + + if ((position < 0xFFFF) && (depth < 0xFF)) { + int ep = position | (depth << 16) | (flags << 24); + pr = scheme_make_integer(ep); + } else { + pr = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(pr)[0] = scheme_make_integer(position); + SCHEME_VEC_ELS(pr)[1] = scheme_make_integer(flags); + SCHEME_VEC_ELS(pr)[2] = scheme_make_integer(depth); + } + v = scheme_hash_get_atomic(toplevels_ht, pr); + if (v) + return v; + } else + pr = NULL; + + tl = (Scheme_Toplevel *)scheme_malloc_atomic_tagged(sizeof(Scheme_Toplevel)); + tl->iso.so.type = (resolved ? scheme_toplevel_type : scheme_compiled_toplevel_type); + tl->depth = depth; + tl->position = position; + SCHEME_TOPLEVEL_FLAGS(tl) = flags; + + if (resolved) { + if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) { + toplevels_ht = scheme_make_hash_table_equal(); + } + scheme_hash_set_atomic(toplevels_ht, pr, (Scheme_Object *)tl); + } + + return (Scheme_Object *)tl; +} + +Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec, + int imported) +{ + Comp_Prefix *cp = env->prefix; + Scheme_Hash_Table *ht; + Scheme_Object *o; + + if (rec && rec[drec].dont_mark_local_use) { + /* Make up anything; it's going to be ignored. */ + return scheme_make_toplevel(0, 0, 0, 0); + } + + ht = cp->toplevels; + if (!ht) { + ht = scheme_make_hash_table(SCHEME_hash_ptr); + cp->toplevels = ht; + } + + o = scheme_hash_get(ht, var); + if (o) + return o; + + o = scheme_make_toplevel(0, cp->num_toplevels, 0, imported ? SCHEME_TOPLEVEL_READY : 0); + + cp->num_toplevels++; + scheme_hash_set(ht, var, o); + + return o; +} + +Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags) +{ + Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl; + return scheme_make_toplevel(tl->depth, tl->position, 0, flags); +} + +Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + Comp_Prefix *cp = env->prefix; + Scheme_Local *l; + Scheme_Object *o; + int pos; + + if (rec && rec[drec].dont_mark_local_use) { + /* Make up anything; it's going to be ignored. */ + l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); + l->iso.so.type = scheme_compiled_quote_syntax_type; + l->position = 0; + + return (Scheme_Object *)l; + } + + if (!cp->stxes) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + cp->stxes = ht; + } + + pos = cp->num_stxes; + + l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); + l->iso.so.type = scheme_compiled_quote_syntax_type; + l->position = pos; + + cp->num_stxes++; + o = (Scheme_Object *)l; + + scheme_hash_set(cp->stxes, var, o); + + return o; +} + +void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec, + Scheme_Env *menv) +{ + Scheme_Object *v, *insp; + + if (rec && rec[drec].dont_mark_local_use) { + return; + } + + insp = menv->module->insp; + + v = env->prefix->uses_unsafe; + if (!v) + v = insp; + else if (!SAME_OBJ(v, insp)) { + Scheme_Hash_Tree *ht; + + if (SCHEME_HASHTRP(v)) { + ht = (Scheme_Hash_Tree *)v; + } else { + ht = scheme_make_hash_tree(0); + ht = scheme_hash_tree_set(ht, v, scheme_true); + } + + if (!scheme_hash_tree_get(ht, insp)) { + ht = scheme_hash_tree_set(ht, insp, scheme_true); + env->prefix->uses_unsafe = (Scheme_Object *)ht; + } + } +} + +/*========================================================================*/ +/* compile-time env, lookup bindings */ +/*========================================================================*/ + +static void init_scheme_local() +{ + int i, k, cor; + +#ifndef USE_TAGGED_ALLOCATION + GC_CAN_IGNORE Scheme_Local *all; + + all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) + * (MAX_CONST_LOCAL_FLAG_VAL + 1) + * MAX_CONST_LOCAL_TYPES + * MAX_CONST_LOCAL_POS); +# ifdef MEMORY_COUNTING_ON + scheme_misc_count += (sizeof(Scheme_Local) + * (MAX_CONST_LOCAL_FLAG_VAL + 1) + * MAX_CONST_LOCAL_TYPES + * MAX_CONST_LOCAL_POS); +# endif +#endif + + for (i = 0; i < MAX_CONST_LOCAL_POS; i++) { + for (k = 0; k < MAX_CONST_LOCAL_TYPES; k++) { + for (cor = 0; cor < (MAX_CONST_LOCAL_FLAG_VAL + 1); cor++) { + Scheme_Object *v; + +#ifndef USE_TAGGED_ALLOCATION + v = (Scheme_Object *)(all++); +#else + v = (Scheme_Object *)scheme_malloc_eternal_tagged(sizeof(Scheme_Local)); +#endif + v->type = k + scheme_local_type; + SCHEME_LOCAL_POS(v) = i; + SCHEME_LOCAL_FLAGS(v) = cor; + + scheme_local[i][k][cor] = v; + } + } + } +} + +static void init_toplevels() +{ + int i, k, cnst; + +#ifndef USE_TAGGED_ALLOCATION + GC_CAN_IGNORE Scheme_Toplevel *all; + + all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel) + * MAX_CONST_TOPLEVEL_DEPTH + * MAX_CONST_TOPLEVEL_POS + * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); +# ifdef MEMORY_COUNTING_ON + scheme_misc_count += (sizeof(Scheme_Toplevel) + * MAX_CONST_TOPLEVEL_DEPTH + * MAX_CONST_TOPLEVEL_POS + * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); +# endif +#endif + + for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) { + for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) { + for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) { + Scheme_Toplevel *v; + +#ifndef USE_TAGGED_ALLOCATION + v = (all++); +#else + v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel)); +#endif + v->iso.so.type = scheme_toplevel_type; + v->depth = i; + v->position = k; + SCHEME_TOPLEVEL_FLAGS(v) = cnst; + + toplevels[i][k][cnst] = (Scheme_Object *)v; + } + } + } +} + +static Scheme_Object *alloc_local(short type, int pos) +{ + Scheme_Object *v; + + v = (Scheme_Object *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); + v->type = type; + SCHEME_LOCAL_POS(v) = pos; + + return (Scheme_Object *)v; +} + +Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags) +{ + int k; + Scheme_Object *v, *key; + + k = type - scheme_local_type; + + /* Helper for reading bytecode: make sure flags is a valid value */ + switch (flags) { + case 0: + case SCHEME_LOCAL_CLEAR_ON_READ: + case SCHEME_LOCAL_OTHER_CLEARS: + case SCHEME_LOCAL_FLONUM: + break; + default: + flags = SCHEME_LOCAL_OTHER_CLEARS; + break; + } + + if (pos < MAX_CONST_LOCAL_POS) { + return scheme_local[pos][k][flags]; + } + + key = scheme_make_integer(pos); + if (flags) { + key = scheme_make_pair(scheme_make_integer(flags), key); + } + + v = scheme_hash_get(locals_ht[k], key); + if (v) + return v; + + v = alloc_local(type, pos); + SCHEME_LOCAL_FLAGS(v) = flags; + + if (locals_ht[k]->count > TABLE_CACHE_MAX_SIZE) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + locals_ht[k] = ht; + } + + scheme_hash_set(locals_ht[k], key, v); + + return v; +} + +static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame, + int i, int j, int p, int flags) +/* Generates a Scheme_Local record for a static distance coodinate, and also + marks the variable as used for closures. */ +{ + int cnt, u; + + u = COMPILE_DATA(frame)->use[i]; + + u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING)) + ? CONSTRAINED_USE + : ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_USE)) + | ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF)) + ? WAS_SET_BANGED + : 0)); + + cnt = ((u & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); + if (cnt < SCHEME_USE_COUNT_INF) + cnt++; + u -= (u & SCHEME_USE_COUNT_MASK); + u |= (cnt << SCHEME_USE_COUNT_SHIFT); + + COMPILE_DATA(frame)->use[i] = u; + if (i < COMPILE_DATA(frame)->min_use) + COMPILE_DATA(frame)->min_use = i; + COMPILE_DATA(frame)->any_use = 1; + + return (Scheme_Local *)scheme_make_local(scheme_local_type, p + i, 0); +} + +Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, + Scheme_Object *stxsym, Scheme_Object *insp, + int pos, intptr_t mod_phase) +{ + Scheme_Object *val; + Scheme_Hash_Table *ht; + + if (!env->modvars) { + ht = scheme_make_hash_table(SCHEME_hash_ptr); + env->modvars = ht; + } + + stxsym = SCHEME_STX_SYM(stxsym); + + ht = (Scheme_Hash_Table *)scheme_hash_get(env->modvars, modidx); + + if (!ht) { + ht = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(env->modvars, modidx, (Scheme_Object *)ht); + } + + /* Loop for inspector-specific hash table, maybe: */ + while (1) { + + val = scheme_hash_get(ht, stxsym); + + if (!val) { + Module_Variable *mv; + + mv = MALLOC_ONE_TAGGED(Module_Variable); + mv->so.type = scheme_module_variable_type; + + mv->modidx = modidx; + mv->sym = stxsym; + mv->insp = insp; + mv->pos = pos; + mv->mod_phase = (int)mod_phase; + + val = (Scheme_Object *)mv; + + scheme_hash_set(ht, stxsym, val); + + break; + } else { + /* Check that inspector is the same. */ + Module_Variable *mv = (Module_Variable *)val; + + if (!SAME_OBJ(mv->insp, insp)) { + /* Need binding for a different inspector. Try again. */ + val = scheme_hash_get(ht, insp); + if (!val) { + Scheme_Hash_Table *ht2; + /* Make a table for this specific inspector */ + ht2 = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(ht, insp, (Scheme_Object *)ht2); + ht = ht2; + /* loop... */ + } else + ht = (Scheme_Hash_Table *)val; + } else + break; + } + } + + return val; +} + +Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, + int mode, /* -1, 0 => lookup; 2, 3 => define + -1 and 3 => use temp table + 1 would mean define if no match; not currently used */ + Scheme_Object *phase, int *_skipped) +/* The `env' argument can actually be a hash table. */ +{ + Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg; + int best_match_skipped, ms, one_mark; + Scheme_Hash_Table *marked_names, *temp_marked_names, *dest_marked_names; + + sym = SCHEME_STX_SYM(id); + + if (_skipped) + *_skipped = -1; + + if (SCHEME_HASHTP((Scheme_Object *)env)) { + marked_names = (Scheme_Hash_Table *)env; + temp_marked_names = NULL; + } else { + /* If there's no table and we're not defining, bail out fast */ + if ((mode <= 0) && !env->rename_set) + return sym; + marked_names = scheme_get_module_rename_marked_names(env->rename_set, + phase ? phase : scheme_make_integer(env->phase), + 0); + temp_marked_names = env->temp_marked_names; + } + + if (mode > 0) { + /* If we're defining, see if we need to create a table. Getting + marks is relatively expensive, but we only do this once per + definition. */ + if (!bdg) + bdg = scheme_stx_moduleless_env(id); + marks = scheme_stx_extract_marks(id); + if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg)) + return sym; + } + + if (!marked_names) { + scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); + marked_names = scheme_get_module_rename_marked_names(env->rename_set, + phase ? phase : scheme_make_integer(env->phase), + 1); + } + if (!temp_marked_names && (mode > 2)) { + /* The "temp" marked name table is used to correlate marked module + requires with similarly marked provides. We don't go through + the normal rename table because (for efficiency) the marks in + this case are handled more directly in the shared_pes module + renamings. */ + temp_marked_names = scheme_make_hash_table(SCHEME_hash_ptr); + env->temp_marked_names = temp_marked_names; + } + + map = scheme_hash_get(marked_names, sym); + if (!map && ((mode < 0) || (mode > 2)) && temp_marked_names) + map = scheme_hash_get(temp_marked_names, sym); + + if (!map) { + /* If we're not defining, we can bail out before extracting marks. */ + if (mode <= 0) + return sym; + else + map = scheme_null; + } + + if (!bdg) { + /* We need lexical binding, if any, too: */ + bdg = scheme_stx_moduleless_env(id); + } + + if (!marks) { + /* We really do need the marks. Get them. */ + marks = scheme_stx_extract_marks(id); + if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg)) + return sym; + } + + best_match = NULL; + best_match_skipped = scheme_list_length(marks); + if (best_match_skipped == 1) { + /* A mark list of length 1 is the common case. + Since the list is otherwise marshaled into .zo, etc., + simplify by extracting just the mark: */ + marks = SCHEME_CAR(marks); + one_mark = 1; + } else + one_mark = 0; + + if (!SCHEME_TRUEP(bdg)) + bdg = NULL; + + /* Find a mapping that matches the longest tail of marks */ + for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + amarks = SCHEME_CAR(a); + + if (SCHEME_VECTORP(amarks)) { + abdg = SCHEME_VEC_ELS(amarks)[1]; + amarks = SCHEME_VEC_ELS(amarks)[0]; + } else + abdg = NULL; + + if (SAME_OBJ(abdg, bdg)) { + if (mode > 0) { + if (scheme_equal(amarks, marks)) { + best_match = SCHEME_CDR(a); + break; + } + } else { + if (!SCHEME_PAIRP(marks)) { + /* To be better than nothing, could only match exactly: */ + if (scheme_equal(amarks, marks) + || SCHEME_NULLP(amarks)) { + best_match = SCHEME_CDR(a); + best_match_skipped = 0; + } + } else { + /* amarks can match a tail of marks: */ + for (m = marks, ms = 0; + SCHEME_PAIRP(m) && (ms < best_match_skipped); + m = SCHEME_CDR(m), ms++) { + + cm = m; + if (!SCHEME_PAIRP(amarks)) { + /* If we're down to the last element + of marks, then extract it to try to + match the symbol amarks. */ + if (SCHEME_NULLP(SCHEME_CDR(m))) + cm = SCHEME_CAR(m); + } + + if (scheme_equal(amarks, cm)) { + best_match = SCHEME_CDR(a); + best_match_skipped = ms; + break; + } + } + } + } + } + } + + if (!best_match) { + if (mode <= 0) { + return sym; + } + + /* Last chance before making up a new name. If we're processing a + module body generated by `expand', then we picked a name last + time around. We can't pick a new name now, otherwise + "redundant" module renamings wouldn't be redundant. (See + simpify in "syntax.c".) So check for a context-determined + existing rename. */ + if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { + Scheme_Object *mod, *nm = id; + mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL); + if (mod /* must refer to env->module, otherwise there would + have been an error before getting here */ + && NOT_SAME_OBJ(nm, sym)) + /* It has a rename already! */ + best_match = nm; + } + + /* Adding a definition. We "gensym" here in a sense; actually, we + use a symbol table that's in parallel to the normal table, so + that we get the same parallel-symbol when unmarshalling + code. We use a counter attached to the environment. Normally, + this counter just increments, but if a module is re-expanded, + then the counter starts at 0 for the re-expand, and we may + re-pick an existing name. To avoid re-picking the same name, + double-check for a mapping in the environment by inspecting the + renames attached to id. In the top-level environment, it's + still possible to get a collision, because separately compiled + code might be loaded into the same environment (which is just + too bad). */ + if (!best_match) { + char onstack[50], *buf; + intptr_t len; + + while (1) { + env->id_counter++; + len = SCHEME_SYM_LEN(sym); + if (len <= 35) + buf = onstack; + else + buf = scheme_malloc_atomic(len + 15); + memcpy(buf, SCHEME_SYM_VAL(sym), len); + + /* The dot here is significant; it might gets stripped away when + printing the symbol */ + sprintf(buf XFORM_OK_PLUS len, ".%d", env->id_counter); + + best_match = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + + if (!scheme_stx_parallel_is_used(best_match, id)) { + /* Also check environment's rename tables. This last check + includes the temp table. It also turns out to matter for + compiling in `module->namespace' contexts, because no + renaming is added after expansion to record the rename + table. */ + if (!scheme_tl_id_is_sym_used(marked_names, best_match) + && (!temp_marked_names + || !scheme_tl_id_is_sym_used(temp_marked_names, best_match))) { + /* Ok, no matches, so this name is fine. */ + break; + } + } + + /* Otherwise, increment counter and try again... */ + } + } + if (bdg) { + a = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(a)[0] = marks; + SCHEME_VEC_ELS(a)[1] = bdg; + marks = a; + } + a = scheme_make_pair(marks, best_match); + map = scheme_make_pair(a, map); + + dest_marked_names = ((mode < 0) || (mode > 2)) ? temp_marked_names : marked_names; + scheme_hash_set(dest_marked_names, sym, map); + { + Scheme_Hash_Table *rev_ht; + rev_ht = (Scheme_Hash_Table *)scheme_hash_get(dest_marked_names, scheme_false); + if (rev_ht) { + scheme_hash_set(rev_ht, best_match, scheme_true); + } + } + } else { + if (_skipped) + *_skipped = best_match_skipped; + } + + return best_match; +} + +int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym) +{ + intptr_t i; + Scheme_Object *l, *a; + Scheme_Hash_Table *rev_ht; + + if (!marked_names) + return 0; + + if (!marked_names->count) + return 0; + + rev_ht = (Scheme_Hash_Table *)scheme_hash_get(marked_names, scheme_false); + + if (!rev_ht) { + rev_ht = scheme_make_hash_table(SCHEME_hash_ptr); + + for (i = marked_names->size; i--; ) { + l = marked_names->vals[i]; + if (l) { + for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + scheme_hash_set(rev_ht, SCHEME_CDR(a), scheme_true); + } + } + scheme_hash_set(marked_names, scheme_false, (Scheme_Object *)rev_ht); + } + } + + if (scheme_hash_get(rev_ht, sym)) + return 1; + + return 0; +} + +static Scheme_Object *make_uid() +{ + char name[20]; + + sprintf(name, "env%d", env_uid_counter++); + return scheme_make_symbol(name); /* uninterned! */ +} + +Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env) +{ + if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED)) + return NULL; + + if (!env->uid) { + Scheme_Object *sym; + sym = make_uid(); + env->uid = sym; + } + return env->uid; +} + +static void make_env_renames(Scheme_Comp_Env *env, int rcount, int rstart, int rstart_sec, int force_multi, + Scheme_Object *stx) +{ + Scheme_Object *rnm; + Scheme_Object *uid = NULL; + int i, pos; + + if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED)) + return; + + scheme_env_frame_uid(env); + + if (force_multi) { + if (env->num_bindings && !env->uids) { + Scheme_Object **uids; + uids = MALLOC_N(Scheme_Object *, env->num_bindings); + env->uids = uids; + } + if (COMPILE_DATA(env)->num_const && !COMPILE_DATA(env)->const_uids) { + Scheme_Object **cuids; + cuids = MALLOC_N(Scheme_Object *, COMPILE_DATA(env)->num_const); + COMPILE_DATA(env)->const_uids = cuids; + } + if (env->uid && !SCHEME_FALSEP(env->uid)) { + uid = env->uid; + env->uid = scheme_false; + } + } + + if (!uid) { + if (env->uid && SCHEME_TRUEP(env->uid)) { + /* single-uid mode (at least for now) */ + uid = env->uid; + } else { + /* multi-uid mode */ + if (!rstart_sec) + uid = COMPILE_DATA(env)->const_uids[rstart]; + else + uid = env->uids[rstart]; + if (!uid) + uid = make_uid(); + } + } + + rnm = scheme_make_rename(uid, rcount); + pos = 0; + + if (!rstart_sec) { + for (i = rstart; (i < COMPILE_DATA(env)->num_const) && (pos < rcount); i++, pos++) { + if (COMPILE_DATA(env)->const_uids) + COMPILE_DATA(env)->const_uids[i] = uid; + scheme_set_rename(rnm, pos, COMPILE_DATA(env)->const_names[i]); + } + rstart = 0; + } + for (i = rstart; pos < rcount; i++, pos++) { + if (env->uids) + env->uids[i] = uid; + scheme_set_rename(rnm, pos, env->values[i]); + } + + if (SCHEME_RIBP(stx)) + scheme_add_rib_rename(stx, rnm); + + if (env->renames) { + if (SCHEME_PAIRP(env->renames) || SCHEME_NULLP(env->renames)) + rnm = scheme_make_pair(rnm, env->renames); + else + rnm = scheme_make_pair(rnm, scheme_make_pair(env->renames, scheme_null)); + } + env->renames = rnm; +} + +Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, + Scheme_Comp_Env *upto) +{ + if (!SCHEME_STXP(stx) && !SCHEME_RIBP(stx)) { + scheme_signal_error("internal error: not syntax or rib"); + return NULL; + } + + if (SCHEME_RIBP(stx)) { + GC_CAN_IGNORE int *s; + s = scheme_stx_get_rib_sealed(stx); + COMPILE_DATA(env)->sealed = s; + } + + while (env != upto) { + if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME + | SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) { + int i, count; + + /* How many slots filled in the frame so far? This can change + due to the style of let* compilation, which generates a + rename record after each binding set. The "const" bindings + are always all in place before we generate any renames in + that case. However, the "const" bindings can grow by + themselves before non-const bindings are installed. */ + count = COMPILE_DATA(env)->num_const; + for (i = env->num_bindings; i--; ) { + if (env->values[i]) + count++; + } + + if (count) { + Scheme_Object *l; + + if (!env->renames || (env->rename_var_count != count)) { + /* Need to create lexical renaming record(s). We create + multiple records as necessary to avoid uids that contain + more than one variable with the same symbol name. + + This is complicated, because we don't want to allocate a + hash table in the common case of a binding set with a few + names. It's also complicated by incremental rename + building: if env->rename_var_count is not zero, we've + done this before for a subset of `values' (and there are + no consts in that case). In the incremental case, we have + a dup_check hash table left from the previous round. */ + Scheme_Hash_Table *ht; + Scheme_Object *name; + int rcount = 0, rstart, rstart_sec = 0, vstart; + + /* rstart is where the to-be-created rename table starts + (saved from last time around, or initially zero). + vstart is where we start looking for new dups. + rstart_sec is TRUE when the new frame starts in the + non-constant area. */ + rstart = env->rename_rstart; + if (env->renames) { + /* Incremental mode. Drop the most recent (first) rename + table, because we'll recreate it: */ + if (SCHEME_PAIRP(env->renames)) + env->renames = SCHEME_CDR(env->renames); + else + env->renames = NULL; + if (SCHEME_RIBP(stx)) + scheme_drop_first_rib_rename(stx); + vstart = env->rename_var_count; + rstart_sec = 1; + /* We already know that the first rcount + are distinct (from the last iteration) */ + rcount = vstart - rstart; + } else + vstart = 0; + + /* Create or find the hash table: */ + if (env->dup_check) + ht = env->dup_check; + else if (env->num_bindings + COMPILE_DATA(env)->num_const > 10) + ht = scheme_make_hash_table(SCHEME_hash_ptr); + else + ht = NULL; + + if (rcount > 16) { + /* Instead of n^2 growth for the rename, just close the current + one off and start fresh. */ + make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); + rcount = 0; + rstart = vstart; + rstart_sec = 1; + if (ht) { + /* Flush the table for a new set: */ + ht = scheme_make_hash_table(SCHEME_hash_ptr); + } + } + + /* Check for dups among the statics, and build a rename for + each dup-free set. */ + + /* First: constants. */ + if (!rstart_sec) { + if (COMPILE_DATA(env)->num_const) { + /* Start at the beginning, always. */ + for (i = 0; i < COMPILE_DATA(env)->num_const; i++) { + int found = 0; + name = SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[i]); + if (ht) { + if (scheme_hash_get(ht, name)) + found = 1; + else + scheme_hash_set(ht, name, scheme_true); + } else { + int j; + for (j = rstart; j < i; j++) { + if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) { + found = 1; + break; + } + } + } + + if (found) { + make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); + rcount = 1; + rstart = i; + if (ht) { + /* Flush the table for a new set: */ + ht = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(ht, name, scheme_true); + } + } else + rcount++; + } + } else + rstart_sec = 1; + } + + for (i = vstart; (i < env->num_bindings) && env->values[i]; i++) { + int found = 0; + name = SCHEME_STX_VAL(env->values[i]); + + if (ht) { + if (scheme_hash_get(ht, name)) + found = 1; + else + scheme_hash_set(ht, name, scheme_true); + } else { + int j; + if (!rstart_sec) { + /* Look in consts, first: */ + for (j = rstart; j < COMPILE_DATA(env)->num_const; j++) { + if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) { + found = 1; + break; + } + } + + j = 0; + } else + j = rstart; + + if (!found) { + for (; j < i; j++) { + if (SAME_OBJ(name, SCHEME_STX_VAL(env->values[j]))) { + found = 1; + break; + } + } + } + } + + if (found) { + make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); + rcount = 1; + rstart = i; + rstart_sec = 1; + if (ht) { + /* Flush the table for a new set: */ + ht = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(ht, name, scheme_true); + } + } else + rcount++; + } + + make_env_renames(env, rcount, rstart, rstart_sec, 0, stx); + + env->rename_var_count = count; + env->rename_rstart = rstart; + if (count < env->num_bindings) { + /* save for next time around: */ + env->dup_check = ht; + } else { + /* drop a saved table if there; we're done with all increments */ + env->dup_check = NULL; + } + } + + if (SCHEME_STXP(stx)) { + for (l = env->renames; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + stx = scheme_add_rename(stx, SCHEME_CAR(l)); + } + if (!SCHEME_NULLP(l)) + stx = scheme_add_rename(stx, l); + } + } + } else if (env->flags & SCHEME_INTDEF_SHADOW) { + /* Just extract existing uids from identifiers, and don't need to + add renames to syntax objects. */ + if (!env->uids) { + Scheme_Object **uids, *uid; + int i; + + uids = MALLOC_N(Scheme_Object *, env->num_bindings); + env->uids = uids; + + for (i = env->num_bindings; i--; ) { + uid = scheme_stx_moduleless_env(env->values[i]); + if (SCHEME_FALSEP(uid)) + scheme_signal_error("intdef shadow binding is #f for %d/%s", + SCHEME_TYPE(env->values[i]), + scheme_write_to_string(SCHEME_STX_VAL(env->values[i]), + NULL)); + env->uids[i] = uid; + } + } + } + + env = env->next; + } + + return stx; +} + +void scheme_seal_env_renames(Scheme_Comp_Env *env) +{ + env->dup_check = NULL; +} + +/*********************************************************************/ + +void create_skip_table(Scheme_Comp_Env *start_frame) +{ + Scheme_Comp_Env *end_frame, *frame; + int depth, dj = 0, dp = 0, i; + Scheme_Hash_Table *table; + int stride = 0; + + depth = start_frame->skip_depth; + + /* Find frames to be covered by the skip table. + The theory here is the same as the `mapped' table + in Scheme_Cert (see "syntax.c") */ + for (end_frame = start_frame->next; + end_frame && ((depth & end_frame->skip_depth) != end_frame->skip_depth); + end_frame = end_frame->next) { + stride++; + } + + table = scheme_make_hash_table(SCHEME_hash_ptr); + + for (frame = start_frame; frame != end_frame; frame = frame->next) { + if (frame->flags & SCHEME_LAMBDA_FRAME) + dj++; + dp += frame->num_bindings; + for (i = frame->num_bindings; i--; ) { + if (frame->values[i]) { + scheme_hash_set(table, SCHEME_STX_VAL(frame->values[i]), scheme_true); + } + } + for (i = COMPILE_DATA(frame)->num_const; i--; ) { + scheme_hash_set(table, SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]), scheme_true); + } + } + + scheme_hash_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame); + scheme_hash_set(table, scheme_make_integer(1), scheme_make_integer(dj)); + scheme_hash_set(table, scheme_make_integer(2), scheme_make_integer(dp)); + + start_frame->skip_table = table; +} + +/*********************************************************************/ +/* + + scheme_lookup_binding() is the main resolver of lexical, module, + and top-level bindings. Depending on the value of `flags', it can + return a value whose type tag is: + + scheme_macro_type (id was bound to syntax), + + scheme_macro_set_type (id was bound to a set!-transformer), + + scheme_macro_id_type (id was bound to a rename-transformer), + + scheme_local_type (id was lexical), + + scheme_variable_type (id is a global or module-bound variable), + or + + scheme_module_variable_type (id is a module-bound variable). + +*/ + +Scheme_Object * +scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, + Scheme_Object *certs, Scheme_Object *in_modidx, + Scheme_Env **_menv, int *_protected, + Scheme_Object **_lexical_binding_id) +{ + Scheme_Comp_Env *frame; + int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0; + Scheme_Bucket *b; + Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; + Scheme_Object *find_id_sym = NULL, *rename_insp = NULL; + Scheme_Env *genv; + intptr_t phase; + + /* Need to know the phase being compiled */ + phase = env->genv->phase; + + /* Walk through the compilation frames */ + for (frame = env; frame->next != NULL; frame = frame->next) { + int i; + Scheme_Object *uid; + + while (1) { + if (frame->skip_table) { + if (!scheme_hash_get(frame->skip_table, SCHEME_STX_VAL(find_id))) { + /* Skip ahead. 0 maps to frame, 1 maps to j delta, and 2 maps to p delta */ + val = scheme_hash_get(frame->skip_table, scheme_make_integer(1)); + j += (int)SCHEME_INT_VAL(val); + val = scheme_hash_get(frame->skip_table, scheme_make_integer(2)); + p += (int)SCHEME_INT_VAL(val); + frame = (Scheme_Comp_Env *)scheme_hash_get(frame->skip_table, scheme_make_integer(0)); + } else + break; + } else if (frame->skip_depth && !(frame->skip_depth & 0x1F)) { + /* We're some multiple of 32 frames deep. Build a skip table and try again. */ + create_skip_table(frame); + } else + break; + } + + if (frame->flags & SCHEME_LAMBDA_FRAME) + j++; + + if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) { + if (frame->flags & SCHEME_FOR_STOPS) + skip_stops = 1; + + uid = scheme_env_frame_uid(frame); + + if (!find_id_sym + && (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) + find_id_sym = scheme_stx_get_module_eq_sym(find_id, scheme_make_integer(phase)); + + for (i = frame->num_bindings; i--; ) { + if (frame->values[i]) { + if (frame->uids) + uid = frame->uids[i]; + if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i])) + && (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase)) + || ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME) + && scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym)) + || ((frame->flags & SCHEME_CAPTURE_LIFTED) + && scheme_stx_bound_eq(find_id, frame->values[i], scheme_make_integer(phase))))) { + /* Found a lambda-, let-, etc. bound variable: */ + /* First, check certs (don't bind with fewer certs): */ + if (!(flags & SCHEME_NO_CERT_CHECKS) + && !(frame->flags & (SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) { + if (scheme_stx_has_more_certs(find_id, certs, frame->values[i], frame->certs)) { + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "reference is more certified than binding"); + return NULL; + } + } + /* Looks ok; return a lexical reference */ + if (_lexical_binding_id) { + if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) + val = scheme_stx_remove_extra_marks(find_id, frame->values[i], + ((frame->flags & SCHEME_CAPTURE_LIFTED) + ? NULL + : uid)); + else + val = find_id; + *_lexical_binding_id = val; + } + if (flags & SCHEME_DONT_MARK_USE) + return scheme_make_local(scheme_local_type, 0, 0); + else + return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags); + } + } + } + + for (i = COMPILE_DATA(frame)->num_const; i--; ) { + int issame; + if (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME) + issame = scheme_stx_module_eq2(find_id, COMPILE_DATA(frame)->const_names[i], + scheme_make_integer(phase), find_id_sym); + else { + if (COMPILE_DATA(frame)->const_uids) uid = COMPILE_DATA(frame)->const_uids[i]; + issame = (SAME_OBJ(SCHEME_STX_VAL(find_id), + SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i])) + && scheme_stx_env_bound_eq(find_id, COMPILE_DATA(frame)->const_names[i], uid, + scheme_make_integer(phase))); + } + + if (issame) { + if (!(flags & SCHEME_NO_CERT_CHECKS) + && !(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) { + if (scheme_stx_has_more_certs(find_id, certs, COMPILE_DATA(frame)->const_names[i], frame->certs)) { + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "reference is more certified than binding"); + return NULL; + } + } + + if (_lexical_binding_id) { + if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) + val = scheme_stx_remove_extra_marks(find_id, COMPILE_DATA(frame)->const_names[i], + ((frame->flags & SCHEME_CAPTURE_LIFTED) + ? NULL + : uid)); + else + val = find_id; + *_lexical_binding_id = val; + } + + val = COMPILE_DATA(frame)->const_vals[i]; + + if (!val) { + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "identifier used out of context"); + return NULL; + } + + if (SCHEME_FALSEP(val)) { + /* Corresponds to a run-time binding (but will be replaced later + through a renaming to a different binding) */ + if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) + return scheme_make_local(scheme_local_type, 0, 0); + return NULL; + } + + if (!(flags & SCHEME_ENV_CONSTANTS_OK)) { + if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) + return val; + else + scheme_wrong_syntax(scheme_set_stx_string, NULL, find_id, + "local syntax identifier cannot be mutated"); + return NULL; + } + + return val; + } + } + } + + p += frame->num_bindings; + } + + src_find_id = find_id; + modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, + NULL, NULL, NULL, NULL, &rename_insp); + /* If modidx and modidx is not #, then find_id is now a + symbol, otherwise it's still an identifier. */ + + /* Used out of context? */ + if (SAME_OBJ(modidx, scheme_undefined)) { + if (SCHEME_STXP(find_id)) { + /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */ + find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); + if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id))) + modidx = NULL; /* yes, it is bound */ + } + + if (modidx) { + if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "identifier used out of context"); + } + if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) + return scheme_make_local(scheme_local_type, 0, 0); + return NULL; + } + } + + if (modidx) { + /* If it's an access path, resolve it: */ + modname = scheme_module_resolve(modidx, 1); + + if (env->genv->module && SAME_OBJ(modname, env->genv->module->modname)) { + modidx = NULL; + modname = NULL; + genv = env->genv; + /* So we can distinguish between unbound identifiers in a module + and references to top-level definitions: */ + module_self_reference = 1; + } else { + genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase)); + + if (!genv) { + if (env->genv->phase) { + /* The failure might be due a laziness in required-syntax + execution. Force all laziness at the prior level + and try again. */ + scheme_module_force_lazy(env->genv, 1); + genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase)); + } + + if (!genv) { + scheme_wrong_syntax("require", NULL, src_find_id, + "namespace mismatch; reference (phase %d) to a module" + " %D that is not available (phase level %d)", + env->genv->phase, modname, SCHEME_INT_VAL(mod_defn_phase)); + return NULL; + } + } + } + } else { + genv = env->genv; + modname = NULL; + + if (genv->module && genv->disallow_unbound) { + /* Free identifier. Maybe don't continue. */ + if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { + scheme_wrong_syntax(((flags & SCHEME_SETTING) + ? scheme_set_stx_string + : scheme_var_ref_string), + NULL, src_find_id, "unbound identifier in module"); + return NULL; + } + if (flags & SCHEME_NULL_FOR_UNBOUND) + return NULL; + } + } + + if (_menv && genv->module) + *_menv = genv; + + if (!modname && SCHEME_STXP(find_id)) + find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); + else + find_global_id = find_id; + + /* Try syntax table: */ + if (modname) { + val = scheme_module_syntax(modname, env->genv, find_id); + if (val && !(flags & SCHEME_NO_CERT_CHECKS)) + scheme_check_accessible_in_module(genv, env->insp, in_modidx, + find_id, src_find_id, certs, NULL, rename_insp, + -2, 0, + NULL, NULL, + env->genv, NULL); + } else { + /* Only try syntax table if there's not an explicit (later) + variable mapping: */ + if (genv->shadowed_syntax + && scheme_hash_get(genv->shadowed_syntax, find_global_id)) + val = NULL; + else + val = scheme_lookup_in_table(genv->syntax, (const char *)find_global_id); + } + + if (val) { + return val; + } + + if (modname) { + Scheme_Object *pos; + if (flags & SCHEME_NO_CERT_CHECKS) + pos = 0; + else + pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx, + find_id, src_find_id, certs, NULL, rename_insp, -1, 1, + _protected, NULL, env->genv, NULL); + modpos = (int)SCHEME_INT_VAL(pos); + } else + modpos = -1; + + if (modname && (flags & SCHEME_SETTING)) { + if (SAME_OBJ(src_find_id, find_id) || SAME_OBJ(SCHEME_STX_SYM(src_find_id), find_id)) + find_id = NULL; + scheme_wrong_syntax(scheme_set_stx_string, find_id, src_find_id, "cannot mutate module-required identifier"); + return NULL; + } + + if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) + && (genv->module && genv->disallow_unbound)) { + /* Check for set! of unbound identifier: */ + if (!scheme_lookup_in_table(genv->toplevel, (const char *)find_global_id)) { + scheme_wrong_syntax(((flags & SCHEME_SETTING) + ? scheme_set_stx_string + : scheme_var_ref_string), + NULL, src_find_id, "unbound identifier in module"); + return NULL; + } + } + + if (!modname && (flags & SCHEME_NULL_FOR_UNBOUND)) { + if (module_self_reference) { + /* Since the module has a rename for this id, it's certainly defined. */ + if (!(flags & SCHEME_RESOLVE_MODIDS)) { + /* This is the same thing as #%top handling in compile mode. But + for expand mode, it prevents wrapping the identifier with #%top. */ + /* Don't need a pos, because the symbol's gensym-ness (if any) will be + preserved within the module. */ + return scheme_hash_module_variable(genv, genv->module->self_modidx, find_id, + genv->module->insp, + -1, genv->mod_phase); + } + } else + return NULL; + } + + /* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad + idea, because it causes module instances to be preserved. */ + if (modname && !(flags & SCHEME_RESOLVE_MODIDS) + && (!(scheme_is_kernel_modname(modname) + || scheme_is_unsafe_modname(modname) + || scheme_is_flfxnum_modname(modname) + || scheme_is_futures_modname(modname)) + || (flags & SCHEME_REFERENCING))) { + /* Create a module variable reference, so that idx is preserved: */ + return scheme_hash_module_variable(env->genv, modidx, find_id, + genv->module->insp, + modpos, SCHEME_INT_VAL(mod_defn_phase)); + } + + if (!modname + && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) + && genv->module + && !(flags & SCHEME_RESOLVE_MODIDS)) { + /* Need to return a variable reference in this case, too. */ + return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, + genv->module->insp, + modpos, genv->mod_phase); + } + + b = scheme_bucket_from_table(genv->toplevel, (char *)find_global_id); + + if ((flags & SCHEME_ELIM_CONST) && b && b->val + && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST) + && !(flags & SCHEME_GLOB_ALWAYS_REFERENCE) + && (!modname || scheme_is_kernel_modname(modname))) + return (Scheme_Object *)b->val; + + ASSERT_IS_VARIABLE_BUCKET(b); + scheme_set_bucket_home(b, genv); + + return (Scheme_Object *)b; +} + +int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env) +{ + 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)) + return 1; + } else + return 1; + } else { + if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) { + Scheme_Env *home; + home = scheme_get_bucket_home((Scheme_Bucket *)var); + if (!SAME_OBJ(home, env->genv)) + return 1; + } else + return 1; + } + return 0; +} + +Scheme_Object *scheme_extract_unsafe(Scheme_Object *o) +{ + Scheme_Env *home; + home = scheme_get_bucket_home((Scheme_Bucket *)o); + if (home && home->module && scheme_is_unsafe_modname(home->module->modname)) + return (Scheme_Object *)((Scheme_Bucket *)o)->val; + else + return NULL; +} + +Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o) +{ + Scheme_Env *home; + home = scheme_get_bucket_home((Scheme_Bucket *)o); + if (home && home->module && scheme_is_flfxnum_modname(home->module->modname)) + return (Scheme_Object *)((Scheme_Bucket *)o)->val; + else + return NULL; +} + +Scheme_Object *scheme_extract_futures(Scheme_Object *o) +{ + Scheme_Env *home; + home = scheme_get_bucket_home((Scheme_Bucket *)o); + if (home && home->module && scheme_is_futures_modname(home->module->modname)) + return (Scheme_Object *)((Scheme_Bucket *)o)->val; + else + return NULL; +} + +int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame) +{ + int any_use; + + any_use = COMPILE_DATA(frame)->any_use; + COMPILE_DATA(frame)->any_use = 0; + + return any_use; +} + +int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos) +{ + return COMPILE_DATA(frame)->min_use < pos; +} + +int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count) +{ + int *v, i; + + v = MALLOC_N_ATOMIC(int, count); + memcpy(v, COMPILE_DATA(frame)->use + start, sizeof(int) * count); + + for (i = count; i--; ) { + int old; + old = v[i]; + v[i] = 0; + if (old & (ARBITRARY_USE | ONE_ARBITRARY_USE | CONSTRAINED_USE)) { + v[i] |= SCHEME_WAS_USED; + if (!(old & (ARBITRARY_USE | WAS_SET_BANGED))) { + if (old & ONE_ARBITRARY_USE) + v[i] |= SCHEME_WAS_APPLIED_EXCEPT_ONCE; + else + v[i] |= SCHEME_WAS_ONLY_APPLIED; + } + } + if (old & WAS_SET_BANGED) + v[i] |= SCHEME_WAS_SET_BANGED; + v[i] |= (old & SCHEME_USE_COUNT_MASK); + } + + return v; +} + +/*========================================================================*/ +/* macro hooks */ +/*========================================================================*/ + + +Scheme_Object * +scheme_do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[]) +{ + Scheme_Env *menv; + Scheme_Comp_Env *env, *orig_env; + Scheme_Object *id, *ids, *rev_ids, *local_mark, *expr, *data, *vec, *id_sym; + Scheme_Lift_Capture_Proc cp; + Scheme_Object *orig_expr; + int count; + char buf[24]; + + if (stx_pos) { + if (SCHEME_INTP(argv[0])) { + count = (int)SCHEME_INT_VAL(argv[0]); + } else if (SCHEME_BIGNUMP(argv[0])) { + if (SCHEME_BIGPOS(argv[0])) + scheme_raise_out_of_memory(NULL, NULL); + count = -1; + } else + count = -1; + + if (count < 0) + scheme_wrong_type(who, "exact nonnegative integer", 0, argc, argv); + } else + count = 1; + + expr = argv[stx_pos]; + if (!SCHEME_STXP(expr)) + scheme_wrong_type(who, "syntax", stx_pos, argc, argv); + + env = orig_env = scheme_current_thread->current_local_env; + local_mark = scheme_current_thread->current_local_mark; + + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "%s: not currently transforming", + who); + + while (env && !COMPILE_DATA(env)->lifts) { + env = env->next; + } + + if (env) + if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0])) + env = NULL; + + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-lift-expression: no lift target"); + + expr = scheme_add_remove_mark(expr, local_mark); + + /* We don't really need a new symbol each time, since the mark + will generate new bindings. But lots of things work better or faster + when different bindings have different symbols. Use env->genv->id_counter + to help keep name generation deterministic within a module. */ + rev_ids = scheme_null; + while (count--) { + sprintf(buf, "lifted.%d", env->genv->id_counter++); + id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); + + id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0); + id = scheme_add_remove_mark(id, scheme_new_mark()); + + rev_ids = scheme_make_pair(id, rev_ids); + } + ids = scheme_reverse(rev_ids); + + vec = COMPILE_DATA(env)->lifts; + cp = *(Scheme_Lift_Capture_Proc *)SCHEME_VEC_ELS(vec)[1]; + data = SCHEME_VEC_ELS(vec)[2]; + + menv = scheme_current_thread->current_local_menv; + + expr = scheme_stx_cert(expr, scheme_false, + (menv && menv->module) ? menv : NULL, + scheme_current_thread->current_local_certs, + NULL, 1); + + expr = scheme_stx_activate_certs(expr); + orig_expr = expr; + + expr = cp(data, &ids, expr, orig_env); + + expr = scheme_make_pair(expr, SCHEME_VEC_ELS(vec)[0]); + SCHEME_VEC_ELS(vec)[0] = expr; + + SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(scheme_get_expand_observe(), ids, orig_expr); + + rev_ids = scheme_null; + for (; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { + id = SCHEME_CAR(ids); + id = scheme_add_remove_mark(id, local_mark); + rev_ids = scheme_make_pair(id, rev_ids); + } + ids = scheme_reverse(rev_ids); + + return ids; +} + +Scheme_Object * +scheme_local_lift_context(Scheme_Comp_Env *env) +{ + while (env && !COMPILE_DATA(env)->lifts) { + env = env->next; + } + + if (!env) + return scheme_false; + + return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4]; +} + +Scheme_Object * +scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, Scheme_Comp_Env *env) +{ + Scheme_Object *pr; + Scheme_Object *orig_expr; + + while (env) { + if ((COMPILE_DATA(env)->lifts) + && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3])) + break; + env = env->next; + } + + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-lift-module-end-declaration: not currently transforming" + " a run-time expression in a module declaration"); + + expr = scheme_add_remove_mark(expr, local_mark); + orig_expr = expr; + + pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]); + SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr; + + SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr); + + return scheme_void; +} + +Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, + intptr_t phase, Scheme_Object *local_mark, Scheme_Comp_Env *env) +{ + Scheme_Object *mark, *data, *pr; + Scheme_Object *req_form; + + data = NULL; + + while (env) { + if (COMPILE_DATA(env)->lifts + && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5])) { + data = SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5]; + if (SCHEME_RPAIRP(data) + && !SCHEME_CAR(data)) { + env = (Scheme_Comp_Env *)SCHEME_CDR(data); + } else + break; + } else + env = env->next; + } + + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-lift-requires: could not find target context"); + + + mark = scheme_new_mark(); + + if (SCHEME_RPAIRP(data)) + form = scheme_parse_lifted_require(form, phase, mark, SCHEME_CAR(data)); + else + form = scheme_toplevel_require_for_expand(form, phase, env, mark); + + pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]); + SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6] = pr; + + req_form = form; + + form = orig_form; + form = scheme_add_remove_mark(form, local_mark); + form = scheme_add_remove_mark(form, mark); + form = scheme_add_remove_mark(form, local_mark); + + SCHEME_EXPAND_OBSERVE_LIFT_REQUIRE(scheme_get_expand_observe(), req_form, orig_form, form); + + return form; +} + +Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_mark, + Scheme_Comp_Env *env) +{ + Scheme_Object *pr; + + while (env) { + if (COMPILE_DATA(env)->lifts + && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7])) { + break; + } else + env = env->next; + } + + if (!env) + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "syntax-local-lift-provide: not expanding in a module run-time body"); + + form = scheme_add_remove_mark(form, local_mark); + form = scheme_datum_to_syntax(scheme_make_pair(scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), + scheme_false, scheme_sys_wraps(env), + 0, 0), + scheme_make_pair(form, scheme_null)), + form, scheme_false, 0, 0); + + SCHEME_EXPAND_OBSERVE_LIFT_PROVIDE(scheme_get_expand_observe(), form); + + pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]); + SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7] = pr; + + return scheme_void; +} + +Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, + Scheme_Object **_id, int *_use_map) +{ + Scheme_Object *id = NULL, *v; + Scheme_Full_Comp_Env inlined_e; + + scheme_prepare_env_renames(genv, mzMOD_RENAME_TOPLEVEL); + scheme_prepare_compile_env(genv); + + id = scheme_make_renamed_stx(sym, genv->rename_set); + + inlined_e.base.num_bindings = 0; + inlined_e.base.next = NULL; + inlined_e.base.genv = genv; + inlined_e.base.flags = SCHEME_TOPLEVEL_FRAME; + init_compile_data((Scheme_Comp_Env *)&inlined_e); + inlined_e.base.prefix = NULL; + + v = scheme_lookup_binding(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, NULL, NULL, NULL, NULL, NULL); + if (v) { + if (!SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) { + *_use_map = -1; + v = NULL; + } else + v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; + } + + *_id = id; + return v; +} + +Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym_marks, Scheme_Comp_Env *env) +{ + Scheme_Comp_Env *frame; + Scheme_Object *esym, *uid = NULL, *env_marks, *prop; + + if (!unshadowable_symbol) { + REGISTER_SO(unshadowable_symbol); + unshadowable_symbol = scheme_intern_symbol("unshadowable"); + } + + /* Walk backward through the frames, looking for a renaming binding + with the same marks as the given identifier, sym. Skip over + unsealed ribs, though. When we find a match, rename the given + identifier so that it matches frame. */ + for (frame = env; frame->next != NULL; frame = frame->next) { + int i; + + for (i = frame->num_bindings; i--; ) { + if (frame->values[i]) { + if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->values[i]))) { + prop = scheme_stx_property(frame->values[i], unshadowable_symbol, NULL); + if (SCHEME_FALSEP(prop)) { + esym = frame->values[i]; + env_marks = scheme_stx_extract_marks(esym); + if (scheme_equal(env_marks, sym_marks)) { + sym = esym; + if (frame->uids) + uid = frame->uids[i]; + else + uid = frame->uid; + break; + } + } + } + } + } + if (uid) + break; + + if (!COMPILE_DATA(frame)->sealed || *COMPILE_DATA(frame)->sealed) { + for (i = COMPILE_DATA(frame)->num_const; i--; ) { + if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) { + if (SAME_OBJ(SCHEME_STX_VAL(sym), + SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) { + esym = COMPILE_DATA(frame)->const_names[i]; + prop = scheme_stx_property(esym, unshadowable_symbol, NULL); + if (SCHEME_FALSEP(prop)) { + env_marks = scheme_stx_extract_marks(esym); + if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */ + sym = esym; + if (COMPILE_DATA(frame)->const_uids) + uid = COMPILE_DATA(frame)->const_uids[i]; + else + uid = frame->uid; + break; + } + } + } + } + } + } + if (uid) + break; + } + + return uid; +} + +/*========================================================================*/ +/* syntax-checking utils */ +/*========================================================================*/ + +void scheme_check_identifier(const char *formname, Scheme_Object *id, + const char *where, Scheme_Comp_Env *env, + Scheme_Object *form) +{ + if (!where) + where = ""; + + if (!SCHEME_STX_SYMBOLP(id)) + scheme_wrong_syntax(formname, form ? id : NULL, + form ? form : id, + "not an identifier%s", where); +} + +void scheme_begin_dup_symbol_check(DupCheckRecord *r, Scheme_Comp_Env *env) +{ + r->phase = env->genv->phase; + r->count = 0; +} + +void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, + Scheme_Object *symbol, char *what, + Scheme_Object *form) +{ + int i; + + if (r->count <= 5) { + for (i = 0; i < r->count; i++) { + if (scheme_stx_bound_eq(symbol, r->syms[i], scheme_make_integer(r->phase))) + scheme_wrong_syntax(where, symbol, form, + "duplicate %s name", what); + } + + if (r->count < 5) { + r->syms[r->count++] = symbol; + return; + } else { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_bound_id); + r->ht = ht; + for (i = 0; i < r->count; i++) { + scheme_hash_set(ht, r->syms[i], scheme_true); + } + r->count++; + } + } + + if (scheme_hash_get(r->ht, symbol)) { + scheme_wrong_syntax(where, symbol, form, + "duplicate %s name", what); + } + + scheme_hash_set(r->ht, symbol, scheme_true); +} + + +/*========================================================================*/ +/* precise GC traversers */ +/*========================================================================*/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#define MARKS_FOR_COMPENV_C +#include "mzmark.c" + +static void register_traversers(void) +{ + GC_REG_TRAV(scheme_rt_comp_env, mark_comp_env); +} + +END_XFORM_SKIP; + +#endif diff --git a/src/racket/src/compile.c b/src/racket/src/compile.c new file mode 100644 index 0000000000..6ca2f7a896 --- /dev/null +++ b/src/racket/src/compile.c @@ -0,0 +1,5446 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. +*/ + +/* This file implements macro expansion and compilation. Instead of + always fully expanding code and then compiling it, the compiler + expands as it goes, which enables some shortcuts compared to fully + expanding first. + + See "eval.c" for an overview of compilation passes. + + The main compile/expand loop is scheme_compile_expand_expr(). */ + +#include "schpriv.h" +#include "schmach.h" +#include "schexpobs.h" + +/* globals */ +READ_ONLY Scheme_Object *scheme_define_values_syntax; +READ_ONLY Scheme_Object *scheme_define_syntaxes_syntax; +READ_ONLY Scheme_Object *scheme_ref_syntax; +READ_ONLY Scheme_Object *scheme_begin_syntax; +READ_ONLY Scheme_Object *scheme_lambda_syntax; +READ_ONLY Scheme_Object *scheme_compiled_void_code; +READ_ONLY Scheme_Object scheme_undefined[1]; + +/* read-only globals */ +READ_ONLY static Scheme_Object *app_expander; +READ_ONLY static Scheme_Object *datum_expander; +READ_ONLY static Scheme_Object *top_expander; +READ_ONLY static Scheme_Object *stop_expander; + +/* symbols */ +ROSYM static Scheme_Object *lambda_symbol; +ROSYM static Scheme_Object *letrec_values_symbol; +ROSYM static Scheme_Object *let_star_values_symbol; +ROSYM static Scheme_Object *let_values_symbol; +ROSYM static Scheme_Object *begin_symbol; +ROSYM static Scheme_Object *disappeared_binding_symbol; +ROSYM static Scheme_Object *app_symbol; +ROSYM static Scheme_Object *datum_symbol; +ROSYM static Scheme_Object *top_symbol; +ROSYM static Scheme_Object *protected_symbol; +ROSYM static Scheme_Object *quote_symbol; +ROSYM static Scheme_Object *letrec_syntaxes_symbol; +ROSYM static Scheme_Object *values_symbol; + +/* locals */ +static Scheme_Object *lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *define_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *ref_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *quote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *if_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *set_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *case_lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *let_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *stratified_body_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *stratified_body_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); + +static Scheme_Object *unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); + +static Scheme_Object *with_cont_mark_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); + +static Scheme_Object *quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); + +static Scheme_Object *app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); + +static Scheme_Object *expand_lam(int argc, Scheme_Object **argv); + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +#define cons(a,b) scheme_make_pair(a,b) +#define icons(a,b) scheme_make_pair(a,b) + +#define max(a, b) (((a) > (b)) ? (a) : (b)) + +/**********************************************************************/ +/* initialization */ +/**********************************************************************/ + +void scheme_init_syntax (Scheme_Env *env) +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif + + REGISTER_SO(scheme_define_values_syntax); + REGISTER_SO(scheme_define_syntaxes_syntax); + REGISTER_SO(scheme_lambda_syntax); + REGISTER_SO(scheme_begin_syntax); + REGISTER_SO(scheme_compiled_void_code); + + REGISTER_SO(lambda_symbol); + REGISTER_SO(letrec_values_symbol); + REGISTER_SO(let_star_values_symbol); + REGISTER_SO(let_values_symbol); + REGISTER_SO(begin_symbol); + REGISTER_SO(disappeared_binding_symbol); + + scheme_undefined->type = scheme_undefined_type; + + lambda_symbol = scheme_intern_symbol("lambda"); + + letrec_values_symbol = scheme_intern_symbol("letrec-values"); + let_star_values_symbol = scheme_intern_symbol("let*-values"); + let_values_symbol = scheme_intern_symbol("let-values"); + + begin_symbol = scheme_intern_symbol("begin"); + + disappeared_binding_symbol = scheme_intern_symbol("disappeared-binding"); + + scheme_define_values_syntax = scheme_make_compiled_syntax(define_values_syntax, + define_values_expand); + scheme_define_syntaxes_syntax = scheme_make_compiled_syntax(define_syntaxes_syntax, + define_syntaxes_expand); + scheme_lambda_syntax = scheme_make_compiled_syntax(lambda_syntax, + lambda_expand); + scheme_begin_syntax = scheme_make_compiled_syntax(begin_syntax, + begin_expand); + + scheme_add_global_keyword("lambda", + scheme_lambda_syntax, + env); + { + /* Graak lambda binding: */ + Scheme_Object *macro, *fn; + + fn = scheme_make_prim_w_arity(expand_lam, "\316\273", 1, 1); + macro = scheme_alloc_small_object(); + macro->type = scheme_macro_type; + SCHEME_PTR_VAL(macro) = fn; + + scheme_add_global_keyword("\316\273", macro, env); + } + scheme_add_global_keyword("define-values", scheme_define_values_syntax, env); + scheme_add_global_keyword("quote", + scheme_make_compiled_syntax(quote_syntax, + quote_expand), + env); + scheme_add_global_keyword("if", + scheme_make_compiled_syntax(if_syntax, + if_expand), + env); + scheme_add_global_keyword("set!", + scheme_make_compiled_syntax(set_syntax, + set_expand), + env); + scheme_add_global_keyword("#%variable-reference", + scheme_make_compiled_syntax(ref_syntax, + ref_expand), + env); + + scheme_add_global_keyword("#%expression", + scheme_make_compiled_syntax(expression_syntax, + expression_expand), + env); + + scheme_add_global_keyword("case-lambda", + scheme_make_compiled_syntax(case_lambda_syntax, + case_lambda_expand), + env); + + scheme_add_global_keyword("let-values", + scheme_make_compiled_syntax(let_values_syntax, + let_values_expand), + env); + scheme_add_global_keyword("let*-values", + scheme_make_compiled_syntax(let_star_values_syntax, + let_star_values_expand), + env); + scheme_add_global_keyword("letrec-values", + scheme_make_compiled_syntax(letrec_values_syntax, + letrec_values_expand), + env); + + scheme_add_global_keyword("begin", + scheme_begin_syntax, + env); + scheme_add_global_keyword("#%stratified-body", + scheme_make_compiled_syntax(stratified_body_syntax, + stratified_body_expand), + env); + + scheme_add_global_keyword("begin0", + scheme_make_compiled_syntax(begin0_syntax, + begin0_expand), + env); + + scheme_add_global_keyword("unquote", + scheme_make_compiled_syntax(unquote_syntax, + unquote_expand), + env); + scheme_add_global_keyword("unquote-splicing", + scheme_make_compiled_syntax(unquote_syntax, + unquote_expand), + env); + + scheme_add_global_keyword("with-continuation-mark", + scheme_make_compiled_syntax(with_cont_mark_syntax, + with_cont_mark_expand), + env); + + scheme_add_global_keyword("quote-syntax", + scheme_make_compiled_syntax(quote_syntax_syntax, + quote_syntax_expand), + env); + scheme_add_global_keyword("define-syntaxes", scheme_define_syntaxes_syntax, env); + scheme_add_global_keyword("define-values-for-syntax", + scheme_make_compiled_syntax(define_for_syntaxes_syntax, + define_for_syntaxes_expand), + env); + scheme_add_global_keyword("letrec-syntaxes+values", + scheme_make_compiled_syntax(letrec_syntaxes_syntax, + letrec_syntaxes_expand), + env); + + REGISTER_SO(app_symbol); + REGISTER_SO(datum_symbol); + REGISTER_SO(top_symbol); + REGISTER_SO(protected_symbol); + REGISTER_SO(quote_symbol); + REGISTER_SO(letrec_syntaxes_symbol); + REGISTER_SO(values_symbol); + + app_symbol = scheme_intern_symbol("#%app"); + datum_symbol = scheme_intern_symbol("#%datum"); + top_symbol = scheme_intern_symbol("#%top"); + protected_symbol = scheme_intern_symbol("protected"); + quote_symbol = scheme_intern_symbol("quote"); + letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values"); + values_symbol = scheme_intern_symbol("values"); + + REGISTER_SO(app_expander); + REGISTER_SO(datum_expander); + REGISTER_SO(top_expander); + REGISTER_SO(stop_expander); + + app_expander = scheme_make_compiled_syntax(app_syntax, app_expand); + datum_expander = scheme_make_compiled_syntax(datum_syntax, datum_expand); + top_expander = scheme_make_compiled_syntax(top_syntax, top_expand); + stop_expander = scheme_make_compiled_syntax(stop_syntax, stop_expand); + scheme_add_global_keyword("#%app", app_expander, env); + scheme_add_global_keyword("#%datum", datum_expander, env); + scheme_add_global_keyword("#%top", top_expander, env); + + scheme_init_marshal(env); +} + +Scheme_Object * +scheme_make_compiled_syntax(Scheme_Syntax *proc, + Scheme_Syntax_Expander *eproc) +{ + Scheme_Object *syntax; + + syntax = scheme_alloc_eternal_object(); + syntax->type = scheme_syntax_compiler_type; + SCHEME_SYNTAX(syntax) = (Scheme_Object *)proc; + SCHEME_SYNTAX_EXP(syntax) = (Scheme_Object *)eproc; + + return syntax; +} + +/**********************************************************************/ +/* utilities */ +/**********************************************************************/ + +static int check_form(Scheme_Object *form, Scheme_Object *base_form) +{ + int i; + + for (i = 0; SCHEME_STX_PAIRP(form); i++) { + form = SCHEME_STX_CDR(form); + } + + if (!SCHEME_STX_NULLP(form)) { + scheme_wrong_syntax(NULL, form, base_form, "bad syntax (" IMPROPER_LIST_FORM ")"); + } + + return i; +} + +static void bad_form(Scheme_Object *form, int l) +{ + scheme_wrong_syntax(NULL, NULL, form, + "bad syntax (has %d part%s after keyword)", + l - 1, (l != 2) ? "s" : ""); +} + +Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *current_val) +{ + Scheme_Object *name; + + name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL); + if (name && SCHEME_SYMBOLP(name)) + return name; + else + return current_val; +} + +/**********************************************************************/ +/* lambda utils */ +/**********************************************************************/ + +static void lambda_check(Scheme_Object *form) +{ + if (SCHEME_STX_PAIRP(form) + && SCHEME_STX_PAIRP(SCHEME_STX_CDR(form))) { + Scheme_Object *rest; + rest = SCHEME_STX_CDR(form); + if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) + return; + } + + scheme_wrong_syntax(NULL, NULL, form, NULL); +} + +static void lambda_check_args(Scheme_Object *args, Scheme_Object *form, Scheme_Comp_Env *env) +{ + Scheme_Object *v, *a; + DupCheckRecord r; + + if (!SCHEME_STX_SYMBOLP(args)) { + for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { + a = SCHEME_STX_CAR(v); + scheme_check_identifier(NULL, a, NULL, env, form); + } + + if (!SCHEME_STX_NULLP(v)) { + if (!SCHEME_STX_SYMBOLP(v)) { + scheme_check_identifier(NULL, v, NULL, env, form); + } + } + + /* Check for duplicate names: */ + scheme_begin_dup_symbol_check(&r, env); + for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { + Scheme_Object *name; + + name = SCHEME_STX_CAR(v); + scheme_dup_symbol_check(&r, NULL, name, "argument", form); + } + if (!SCHEME_STX_NULLP(v)) { + scheme_dup_symbol_check(&r, NULL, v, "argument", form); + } + } +} + +Scheme_Object *scheme_source_to_name(Scheme_Object *code) + /* Makes up a procedure name when there's not a good one in the source: */ +{ + Scheme_Stx *cstx = (Scheme_Stx *)code; + if ((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) { + char buf[50], src[20]; + Scheme_Object *name; + + if (cstx->srcloc->src && SCHEME_PATHP(cstx->srcloc->src)) { + if (SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) < 20) + memcpy(src, SCHEME_BYTE_STR_VAL(cstx->srcloc->src), SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) + 1); + else { + memcpy(src, SCHEME_BYTE_STR_VAL(cstx->srcloc->src) + SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) - 19, 20); + src[0] = '.'; + src[1] = '.'; + src[2] = '.'; + } + } else { + return NULL; + } + + if (cstx->srcloc->line >= 0) { + sprintf(buf, "%s%s%" PRIdPTR ":%" PRIdPTR, + src, (src[0] ? ":" : ""), cstx->srcloc->line, cstx->srcloc->col - 1); + } else { + sprintf(buf, "%s%s%" PRIdPTR, + src, (src[0] ? "::" : ""), cstx->srcloc->pos); + } + + name = scheme_intern_exact_symbol(buf, strlen(buf)); + return name; + } + + return NULL; +} + +Scheme_Object *combine_name_with_srcloc(Scheme_Object *name, Scheme_Object *code, int src_based_name) +{ + Scheme_Stx *cstx = (Scheme_Stx *)code; + + if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) + && cstx->srcloc->src) { + Scheme_Object *vec; + vec = scheme_make_vector(7, NULL); + SCHEME_VEC_ELS(vec)[0] = name; + SCHEME_VEC_ELS(vec)[1] = cstx->srcloc->src; + if (cstx->srcloc->line >= 0) { + SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(cstx->srcloc->line); + SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(cstx->srcloc->col-1); + } else { + SCHEME_VEC_ELS(vec)[2] = scheme_false; + SCHEME_VEC_ELS(vec)[3] = scheme_false; + } + if (cstx->srcloc->pos >= 0) + SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(cstx->srcloc->pos); + else + SCHEME_VEC_ELS(vec)[4] = scheme_false; + if (cstx->srcloc->span >= 0) + SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(cstx->srcloc->span); + else + SCHEME_VEC_ELS(vec)[5] = scheme_false; + SCHEME_VEC_ELS(vec)[6] = (src_based_name ? scheme_true : scheme_false); + + return vec; + } + + return name; +} + +Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *name; + + name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL); + if (name && SCHEME_SYMBOLP(name)) { + name = combine_name_with_srcloc(name, code, 0); + } else if (name && SCHEME_VOIDP(name)) { + name = scheme_source_to_name(code); + if (name) + name = combine_name_with_srcloc(name, code, 1); + } else { + name = rec[drec].value_name; + if (!name || SCHEME_FALSEP(name)) { + name = scheme_source_to_name(code); + if (name) + name = combine_name_with_srcloc(name, code, 1); + } else { + name = combine_name_with_srcloc(name, code, 0); + } + } + return name; +} + +static Scheme_Object * +make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code, + Scheme_Compile_Info *rec, int drec) +/* Compiles a `lambda' expression */ +{ + Scheme_Object *allparams, *params, *forms, *param, *name; + Scheme_Closure_Data *data; + Scheme_Compile_Info lam; + Scheme_Comp_Env *frame; + int i; + intptr_t num_params; + Closure_Info *cl; + + data = MALLOC_ONE_TAGGED(Scheme_Closure_Data); + + data->iso.so.type = scheme_compiled_unclosed_procedure_type; + + params = SCHEME_STX_CDR(code); + params = SCHEME_STX_CAR(params); + allparams = params; + + num_params = 0; + for (; SCHEME_STX_PAIRP(params); params = SCHEME_STX_CDR(params)) { + num_params++; + } + SCHEME_CLOSURE_DATA_FLAGS(data) = 0; + if (!SCHEME_STX_NULLP(params)) { + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_REST; + num_params++; + } + data->num_params = num_params; + if ((data->num_params > 0) && scheme_has_method_property(code)) + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_IS_METHOD; + + forms = SCHEME_STX_CDR(code); + forms = SCHEME_STX_CDR(forms); + + frame = scheme_new_compilation_frame(data->num_params, SCHEME_LAMBDA_FRAME, env, rec[drec].certs); + params = allparams; + for (i = 0; i < data->num_params; i++) { + if (!SCHEME_STX_PAIRP(params)) + param = params; + else + param = SCHEME_STX_CAR(params); + scheme_add_compilation_binding(i, param, frame); + if (SCHEME_STX_PAIRP(params)) + params = SCHEME_STX_CDR (params); + } + + if (SCHEME_STX_NULLP(forms)) + scheme_wrong_syntax(NULL, NULL, code, "bad syntax (empty body)"); + + forms = scheme_datum_to_syntax(forms, code, code, 0, 0); + forms = scheme_add_env_renames(forms, frame, env); + + name = scheme_build_closure_name(code, rec, drec); + data->name = name; + + scheme_compile_rec_done_local(rec, drec); + + scheme_init_lambda_rec(rec, drec, &lam, 0); + + { + Scheme_Object *datacode; + datacode = scheme_compile_sequence(forms, + scheme_no_defines(frame), + &lam, 0); + data->code = datacode; + } + + scheme_merge_lambda_rec(rec, drec, &lam, 0); + + cl = MALLOC_ONE_RT(Closure_Info); +#ifdef MZTAG_REQUIRED + cl->type = scheme_rt_closure_info; +#endif + { + int *local_flags; + local_flags = scheme_env_get_flags(frame, 0, data->num_params); + cl->local_flags = local_flags; + } + data->closure_map = (mzshort *)cl; + + return (Scheme_Object *)data; +} + +static Scheme_Object * +lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *args; + + lambda_check(form); + + args = SCHEME_STX_CDR(form); + args = SCHEME_STX_CAR(args); + lambda_check_args(args, form, env); + + scheme_rec_add_certs(rec, drec, form); + + return make_closure_compilation(env, form, rec, drec); +} + +static Scheme_Object * +lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *args, *body, *fn; + Scheme_Comp_Env *newenv; + Scheme_Expand_Info erec1; + + SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(erec[drec].observer); + + lambda_check(form); + + args = SCHEME_STX_CDR(form); + args = SCHEME_STX_CAR(args); + + lambda_check_args(args, form, env); + + scheme_rec_add_certs(erec, drec, form); + + newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs); + + body = SCHEME_STX_CDR(form); + body = SCHEME_STX_CDR(body); + body = scheme_datum_to_syntax(body, form, form, 0, 0); + + body = scheme_add_env_renames(body, newenv, env); + + args = scheme_add_env_renames(args, newenv, env); /* for re-expansion */ + SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(erec[drec].observer, args, body); + + fn = SCHEME_STX_CAR(form); + + scheme_init_expand_recs(erec, drec, &erec1, 1); + erec1.value_name = scheme_false; + + return scheme_datum_to_syntax(cons(fn, + cons(args, + scheme_expand_block(body, + newenv, + &erec1, + 0))), + form, form, + 0, 2); +} + +static Scheme_Object *expand_lam(int argc, Scheme_Object **argv) +{ + Scheme_Object *form = argv[0], *args, *fn; + Scheme_Comp_Env *env; + + env = scheme_current_thread->current_local_env; + + lambda_check(form); + + args = SCHEME_STX_CDR(form); + args = SCHEME_STX_CAR(args); + + lambda_check_args(args, form, env); + + fn = SCHEME_STX_CAR(form); + fn = scheme_datum_to_syntax(lambda_symbol, fn, scheme_sys_wraps(env), 0, 0); + + args = SCHEME_STX_CDR(form); + return scheme_datum_to_syntax(cons(fn, args), form, fn, 0, 0); +} + +Scheme_Object *scheme_clone_vector(Scheme_Object *data, int skip, int set_type) +{ + Scheme_Object *naya; + int i, size; + + size = SCHEME_VEC_SIZE(data); + naya = scheme_make_vector(size - skip, NULL); + for (i = skip; i < size; i++) { + SCHEME_VEC_ELS(naya)[i - skip] = SCHEME_VEC_ELS(data)[i]; + } + + if (set_type) + naya->type = data->type; + + return naya; +} + +void scheme_define_parse(Scheme_Object *form, + Scheme_Object **var, Scheme_Object **_stk_val, + int defmacro, + Scheme_Comp_Env *env, + int no_toplevel_check) +{ + Scheme_Object *vars, *rest; + int len; + DupCheckRecord r; + + if (!no_toplevel_check && !scheme_is_toplevel(env)) + scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); + + len = check_form(form, form); + if (len != 3) + bad_form(form, len); + + rest = SCHEME_STX_CDR(form); + vars = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); + *_stk_val = SCHEME_STX_CAR(rest); + + *var = vars; + + scheme_begin_dup_symbol_check(&r, env); + + while (SCHEME_STX_PAIRP(vars)) { + Scheme_Object *name; + + name = SCHEME_STX_CAR(vars); + scheme_check_identifier(NULL, name, NULL, env, form); + + vars = SCHEME_STX_CDR(vars); + + scheme_dup_symbol_check(&r, NULL, name, "binding", form); + } + + if (!SCHEME_STX_NULLP(vars)) + scheme_wrong_syntax(NULL, *var, form, "bad variable list"); +} + +static Scheme_Object * +defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *first = scheme_null, *last = NULL; + + while (SCHEME_STX_PAIRP(var)) { + Scheme_Object *name, *pr, *bucket; + + name = SCHEME_STX_CAR(var); + name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); + + if (rec[drec].resolve_module_ids || !env->genv->module) { + bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); + } else { + /* Create a module variable reference, so that idx is preserved: */ + bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, + name, env->genv->module->insp, + -1, env->genv->mod_phase); + } + /* Get indirection through the prefix: */ + bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec, 0); + + pr = cons(bucket, scheme_null); + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + + var = SCHEME_STX_CDR(var); + } + + return first; +} + +static Scheme_Object * +define_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *var, *val, *targets, *variables, *vec; + + scheme_define_parse(form, &var, &val, 0, env, 0); + variables = var; + + targets = defn_targets_syntax(var, env, rec, drec); + + scheme_compile_rec_done_local(rec, drec); + if (SCHEME_STX_PAIRP(targets) && SCHEME_STX_NULLP(SCHEME_STX_CDR(targets))) { + var = SCHEME_STX_CAR(variables); + rec[drec].value_name = SCHEME_STX_SYM(var); + } + + env = scheme_no_defines(env); + + scheme_rec_add_certs(rec, drec, form); + + val = scheme_compile_expr(val, env, rec, drec); + + vec = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(vec)[0] = targets; + SCHEME_VEC_ELS(vec)[1] = val; + vec->type = scheme_define_values_type; + + return vec; +} + +static Scheme_Object * +define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *var, *val, *fn, *boundname; + + SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(erec[drec].observer); + + scheme_define_parse(form, &var, &val, 0, env, 0); + + env = scheme_no_defines(env); + + if (SCHEME_STX_PAIRP(var) && SCHEME_STX_NULLP(SCHEME_STX_CDR(var))) + boundname = SCHEME_STX_CAR(var); + else + boundname = scheme_false; + erec[drec].value_name = boundname; + + scheme_rec_add_certs(erec, drec, form); + + fn = SCHEME_STX_CAR(form); + return scheme_datum_to_syntax(cons(fn, + cons(var, + cons(scheme_expand_expr(val, env, erec, drec), + scheme_null))), + form, + form, + 0, 2); +} + +/**********************************************************************/ +/* quote */ +/**********************************************************************/ + +static Scheme_Object * +quote_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *v, *rest; + + rest = SCHEME_STX_CDR(form); + if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) + scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)"); + + scheme_compile_rec_done_local(rec, drec); + scheme_default_compile_rec(rec, drec); + + v = SCHEME_STX_CAR(rest); + + if (SCHEME_STXP(v)) + return scheme_syntax_to_datum(v, 0, NULL); + else + return v; +} + +static Scheme_Object * +quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *rest; + + SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(erec[drec].observer); + + rest = SCHEME_STX_CDR(form); + + if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) + scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)"); + + return form; +} + +/**********************************************************************/ +/* if */ +/**********************************************************************/ + +static void check_if_len(Scheme_Object *form, int len) +{ + if (len != 4) { + if (len == 3) { + scheme_wrong_syntax(NULL, NULL, form, + "bad syntax (must have an \"else\" expression)"); + } else { + bad_form(form, len); + } + } +} + +Scheme_Object * +scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp, + Scheme_Object *elsep) +{ + Scheme_Branch_Rec *b; + + if (SCHEME_TYPE(test) > _scheme_compiled_values_types_) { + if (SCHEME_FALSEP(test)) + return elsep; + else + return thenp; + } + + b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); + b->so.type = scheme_branch_type; + + b->test = test; + b->tbranch = thenp; + b->fbranch = elsep; + + return (Scheme_Object *)b; +} + +static Scheme_Object * +if_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + int len, opt; + Scheme_Object *test, *thenp, *elsep, *name, *rest; + Scheme_Compile_Info recs[3]; + + len = check_form(form, form); + check_if_len(form, len); + + name = rec[drec].value_name; + scheme_compile_rec_done_local(rec, drec); + + name = scheme_check_name_property(form, name); + + rest = SCHEME_STX_CDR(form); + test = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); + thenp = SCHEME_STX_CAR(rest); + if (len == 4) { + rest = SCHEME_STX_CDR(rest); + elsep = SCHEME_STX_CAR(rest); + } else + elsep = scheme_compiled_void(); + + scheme_rec_add_certs(rec, drec, form); + + scheme_init_compile_recs(rec, drec, recs, 3); + recs[1].value_name = name; + recs[2].value_name = name; + + env = scheme_no_defines(env); + + test = scheme_compile_expr(test, env, recs, 0); + + if (SCHEME_TYPE(test) > _scheme_compiled_values_types_) { + opt = 1; + + if (SCHEME_FALSEP(test)) { + /* compile other branch only to get syntax checking: */ + recs[2].dont_mark_local_use = 1; + scheme_compile_expr(thenp, env, recs, 2); + + if (len == 4) + test = scheme_compile_expr(elsep, env, recs, 1); + else + test = elsep; + } else { + if (len == 4) { + /* compile other branch only to get syntax checking: */ + recs[2].dont_mark_local_use = 1; + scheme_compile_expr(elsep, env, recs, 2); + } + + test = scheme_compile_expr(thenp, env, recs, 1); + } + } else { + opt = 0; + thenp = scheme_compile_expr(thenp, env, recs, 1); + if (len == 4) + elsep = scheme_compile_expr(elsep, env, recs, 2); + } + + scheme_merge_compile_recs(rec, drec, recs, (opt || (len == 3)) ? 2 : 3); + + if (opt) + return test; + else + return scheme_make_branch(test, thenp, elsep); +} + +static Scheme_Object * +if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *test, *rest, *thenp, *elsep, *fn, *boundname; + int len; + Scheme_Expand_Info recs[3]; + + SCHEME_EXPAND_OBSERVE_PRIM_IF(erec[drec].observer); + + len = check_form(form, form); + + check_if_len(form, len); + + if (len == 3) { + SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer); + } + + env = scheme_no_defines(env); + + boundname = scheme_check_name_property(form, erec[drec].value_name); + + scheme_rec_add_certs(erec, drec, form); + + scheme_init_expand_recs(erec, drec, recs, 3); + recs[0].value_name = scheme_false; + recs[1].value_name = boundname; + recs[2].value_name = boundname; + + rest = SCHEME_STX_CDR(form); + test = SCHEME_STX_CAR(rest); + test = scheme_expand_expr(test, env, recs, 0); + + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + rest = SCHEME_STX_CDR(rest); + thenp = SCHEME_STX_CAR(rest); + thenp = scheme_expand_expr(thenp, env, recs, 1); + + rest = SCHEME_STX_CDR(rest); + if (!SCHEME_STX_NULLP(rest)) { + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + elsep = SCHEME_STX_CAR(rest); + elsep = scheme_expand_expr(elsep, env, recs, 2); + rest = cons(elsep, scheme_null); + } else { + rest = scheme_null; + } + + rest = cons(thenp, rest); + + fn = SCHEME_STX_CAR(form); + return scheme_datum_to_syntax(cons(fn, cons(test, rest)), + form, form, + 0, 2); +} + +/**********************************************************************/ +/* with-continuation-mark */ +/**********************************************************************/ + +static Scheme_Object * +with_cont_mark_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *key, *val, *expr, *name, *orig_form = form; + Scheme_Compile_Info recs[3]; + Scheme_With_Continuation_Mark *wcm; + int len; + len = check_form(form, form); + + if (len != 4) + bad_form(form, len); + + env = scheme_no_defines(env); + + form = SCHEME_STX_CDR(form); + key = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + val = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + expr = SCHEME_STX_CAR(form); + + name = rec[drec].value_name; + scheme_compile_rec_done_local(rec, drec); + + name = scheme_check_name_property(orig_form, name); + + scheme_rec_add_certs(rec, drec, orig_form); + + scheme_init_compile_recs(rec, drec, recs, 3); + recs[2].value_name = name; + + key = scheme_compile_expr(key, env, recs, 0); + val = scheme_compile_expr(val, env, recs, 1); + expr = scheme_compile_expr(expr, env, recs, 2); + + scheme_merge_compile_recs(rec, drec, recs, 3); + + wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + wcm->so.type = scheme_with_cont_mark_type; + wcm->key = key; + wcm->val = val; + wcm->body = expr; + + return (Scheme_Object *)wcm; +} + +static Scheme_Object * +with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *key, *val, *expr, *orig_form = form, *fn, *boundname; + int len; + Scheme_Expand_Info recs[3]; + + SCHEME_EXPAND_OBSERVE_PRIM_WCM(erec[drec].observer); + + len = check_form(form, form); + if (len != 4) + bad_form(form, len); + + env = scheme_no_defines(env); + + boundname = scheme_check_name_property(form, erec[drec].value_name); + + scheme_rec_add_certs(erec, drec, form); + + scheme_init_expand_recs(erec, drec, recs, 3); + recs[0].value_name = scheme_false; + recs[1].value_name = scheme_false; + recs[2].value_name = boundname; + + form = SCHEME_STX_CDR(form); + key = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + val = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + expr = SCHEME_STX_CAR(form); + + key = scheme_expand_expr(key, env, recs, 0); + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + val = scheme_expand_expr(val, env, recs, 1); + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + expr = scheme_expand_expr(expr, env, recs, 2); + + fn = SCHEME_STX_CAR(orig_form); + return scheme_datum_to_syntax(cons(fn, + cons(key, + cons(val, + cons(expr, scheme_null)))), + orig_form, + orig_form, + 0, 2); +} + +/**********************************************************************/ +/* set! */ +/**********************************************************************/ + +static Scheme_Object * +set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Set_Bang *sb; + Scheme_Env *menv = NULL; + Scheme_Object *var, *val, *name, *body, *rest, *find_name; + int l, set_undef; + + l = check_form(form, form); + if (l != 3) + bad_form(form, l); + + rest = SCHEME_STX_CDR(form); + name = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); + body = SCHEME_STX_CAR(rest); + + scheme_check_identifier("set!", name, NULL, env, form); + + find_name = name; + + scheme_rec_add_certs(rec, drec, form); + + while (1) { + var = scheme_lookup_binding(find_name, env, + SCHEME_SETTING + + SCHEME_GLOB_ALWAYS_REFERENCE + + (rec[drec].dont_mark_local_use + ? SCHEME_DONT_MARK_USE + : 0) + + (rec[drec].resolve_module_ids + ? SCHEME_RESOLVE_MODIDS + : 0), + rec[drec].certs, env->in_modidx, + &menv, NULL, NULL); + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { + /* Redirect to a macro? */ + if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { + form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1); + + return scheme_compile_expr(form, env, rec, drec); + } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { + find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL, 1); + SCHEME_USE_FUEL(1); + menv = NULL; + } else + break; + } else + break; + } + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { + scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); + return NULL; + } + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { + var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0); + if (env->genv->module) + SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; + } + + scheme_compile_rec_done_local(rec, drec); + rec[drec].value_name = SCHEME_STX_SYM(name); + + val = scheme_compile_expr(body, scheme_no_defines(env), rec, drec); + + /* check for (set! x x) */ + if (SAME_TYPE(SCHEME_TYPE(var), SCHEME_TYPE(val))) { + if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) { + /* local */ + if (SCHEME_LOCAL_POS(var) == SCHEME_LOCAL_POS(val)) + return scheme_compiled_void(); + } else { + /* global; can't do anything b/c var might be undefined or constant */ + } + } + + set_undef = (rec[drec].comp_flags & COMP_ALLOW_SET_UNDEFINED); + + sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); + sb->so.type = scheme_set_bang_type; + sb->var = var; + sb->val = val; + sb->set_undef = set_undef; + + return (Scheme_Object *)sb; +} + +static Scheme_Object * +set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Env *menv = NULL; + Scheme_Object *name, *var, *fn, *rhs, *find_name, *lexical_binding_id; + int l; + + SCHEME_EXPAND_OBSERVE_PRIM_SET(erec[drec].observer); + + l = check_form(form, form); + if (l != 3) + bad_form(form, l); + + env = scheme_no_defines(env); + + name = SCHEME_STX_CDR(form); + name = SCHEME_STX_CAR(name); + + scheme_check_identifier("set!", name, NULL, env, form); + + find_name = name; + + scheme_rec_add_certs(erec, drec, form); + + while (1) { + /* Make sure it's mutable, and check for redirects: */ + lexical_binding_id = NULL; + var = scheme_lookup_binding(find_name, env, SCHEME_SETTING, + erec[drec].certs, env->in_modidx, + &menv, NULL, &lexical_binding_id); + + SCHEME_EXPAND_OBSERVE_RESOLVE(erec[drec].observer, find_name); + + if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { + /* Redirect to a macro? */ + if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { + + SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form); + + form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1); + + SCHEME_EXPAND_OBSERVE_EXIT_MACRO(erec[drec].observer, form); + + if (erec[drec].depth > 0) + erec[drec].depth--; + + erec[drec].value_name = name; + + return scheme_expand_expr(form, env, erec, drec); + } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { + Scheme_Object *new_name; + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + new_name = scheme_stx_track(new_name, find_name, find_name); + new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); + find_name = new_name; + menv = NULL; + } else + break; + } else { + if (lexical_binding_id) { + find_name = lexical_binding_id; + } + break; + } + } + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { + scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); + } + + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + + + fn = SCHEME_STX_CAR(form); + rhs = SCHEME_STX_CDR(form); + rhs = SCHEME_STX_CDR(rhs); + rhs = SCHEME_STX_CAR(rhs); + + erec[drec].value_name = name; + + rhs = scheme_expand_expr(rhs, env, erec, drec); + + return scheme_datum_to_syntax(cons(fn, + cons(find_name, + cons(rhs, scheme_null))), + form, + form, + 0, 2); +} + +/**********************************************************************/ +/* #%variable-reference */ +/**********************************************************************/ + +static Scheme_Object * +ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Env *menv = NULL; + Scheme_Object *var, *name, *rest, *dummy; + int l, ok; + + l = check_form(form, form); + + /* retaining `dummy' ensures that the environment stays + linked from the actual variable */ + if (rec[drec].comp) + dummy = scheme_make_environment_dummy(env); + else + dummy = NULL; + + if (l == 1) { + if (rec[drec].comp) + var = dummy; + else + var = scheme_void; + } else { + if (l != 2) + bad_form(form, l); + + rest = SCHEME_STX_CDR(form); + name = SCHEME_STX_CAR(rest); + + if (SCHEME_STX_PAIRP(name)) { + rest = SCHEME_STX_CAR(name); + if (env->genv->phase == 0) { + var = scheme_top_stx; + } else { + var = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_top_stx), scheme_false, scheme_sys_wraps(env), 0, 0); + } + ok = scheme_stx_module_eq(rest, var, env->genv->phase); + } else + ok = SCHEME_STX_SYMBOLP(name); + + if (!ok) { + scheme_wrong_syntax("#%variable-reference", name, + form, + "not an identifier or #%%top form"); + return NULL; + } + + if (SCHEME_STX_PAIRP(name)) { + /* FIXME: when using #%top, need to set mutated flag */ + if (rec[drec].comp) + var = scheme_compile_expr(name, env, rec, drec); + else + var = scheme_expand_expr(name, env, rec, drec); + } else { + scheme_rec_add_certs(rec, drec, form); + + var = scheme_lookup_binding(name, env, + SCHEME_REFERENCING + + SCHEME_GLOB_ALWAYS_REFERENCE + + (rec[drec].dont_mark_local_use + ? SCHEME_DONT_MARK_USE + : 0) + + (rec[drec].resolve_module_ids + ? SCHEME_RESOLVE_MODIDS + : 0), + rec[drec].certs, env->in_modidx, + &menv, NULL, NULL); + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { + int imported = 0; + imported = scheme_is_imported(var, env); + + if (rec[drec].comp) { + var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0); + if (!imported && env->genv->module) + SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; + } + } else { + scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a top-level or module variable"); + } + + if (rec[drec].comp) + scheme_compile_rec_done_local(rec, drec); + } + } + + if (rec[drec].comp) { + Scheme_Object *o; + o = scheme_alloc_object(); + o->type = scheme_varref_form_type; + SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; + SCHEME_PTR2_VAL(o) = (Scheme_Object *)dummy; + return o; + } else + return scheme_void; +} + +static Scheme_Object * +ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_VARREF(erec[drec].observer); + + /* Error checking: */ + ref_syntax(form, env, erec, drec); + + /* No change: */ + return form; +} + +/**********************************************************************/ +/* case-lambda */ +/**********************************************************************/ + +Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int mode) +{ + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr; + Scheme_Closure *c; + int i; + + for (i = cl->count; i--; ) { + c = (Scheme_Closure *)cl->array[i]; + if (!ZERO_SIZED_CLOSUREP(c)) { + break; + } + } + + if (i < 0) { + /* We can reconstruct a case-lambda syntactic form. */ + Scheme_Case_Lambda *cl2; + + cl2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + + ((cl->count - 1) * sizeof(Scheme_Object*))); + + cl2->so.type = scheme_case_lambda_sequence_type; + cl2->count = cl->count; + cl2->name = cl->name; + + for (i = cl->count; i--; ) { + c = (Scheme_Closure *)cl->array[i]; + cl2->array[i] = (Scheme_Object *)c->code; + } + + if (mode == 2) { + /* sfs */ + return (Scheme_Object *)cl2; + } else if (mode == 1) { + /* JIT */ + return scheme_case_lambda_jit((Scheme_Object *)cl2); + } else + return (Scheme_Object *)cl2; + } + + return expr; +} + +static void case_lambda_check_line(Scheme_Object *line, Scheme_Object *form, Scheme_Comp_Env *env) +{ + Scheme_Object *body, *args; + + if (!SCHEME_STX_PAIRP(line)) + scheme_wrong_syntax(NULL, line, form, NULL); + + body = SCHEME_STX_CDR(line); + args = SCHEME_STX_CAR(line); + + lambda_check_args(args, form, env); + + if (!SCHEME_STX_PAIRP(body)) + scheme_wrong_syntax(NULL, line, form, "bad syntax (%s)", + SCHEME_STX_NULLP(body) ? "empty body" : IMPROPER_LIST_FORM); +} + +static Scheme_Object * +case_lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *list, *last, *c, *orig_form = form, *name; + Scheme_Case_Lambda *cl; + int i, count = 0; + Scheme_Compile_Info *recs; + + form = SCHEME_STX_CDR(form); + + name = scheme_build_closure_name(orig_form, rec, drec); + + if (SCHEME_STX_NULLP(form)) { + /* Case where there are no cases... */ + form = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + - sizeof(Scheme_Object*)); + + form->type = scheme_case_lambda_sequence_type; + ((Scheme_Case_Lambda *)form)->count = 0; + ((Scheme_Case_Lambda *)form)->name = name; + + scheme_compile_rec_done_local(rec, drec); + scheme_default_compile_rec(rec, drec); + + if (scheme_has_method_property(orig_form)) { + /* See note in schpriv.h about the IS_METHOD hack */ + if (!name) + name = scheme_false; + name = scheme_box(name); + ((Scheme_Case_Lambda *)form)->name = name; + } + + return form; + } + + if (!SCHEME_STX_PAIRP(form)) + scheme_wrong_syntax(NULL, form, orig_form, NULL); + if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) { + c = SCHEME_STX_CAR(form); + + case_lambda_check_line(c, orig_form, env); + + c = cons(scheme_datum_to_syntax(lambda_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), + c); + c = scheme_datum_to_syntax(c, orig_form, orig_form, 0, 2); + + return lambda_syntax(c, env, rec, drec); + } + + scheme_compile_rec_done_local(rec, drec); + + scheme_rec_add_certs(rec, drec, orig_form); + + list = last = NULL; + while (SCHEME_STX_PAIRP(form)) { + Scheme_Object *clause; + clause = SCHEME_STX_CAR(form); + case_lambda_check_line(clause, orig_form, env); + + c = cons(lambda_symbol, clause); + + c = scheme_datum_to_syntax(c, clause, scheme_sys_wraps(env), 0, 0); + + c = cons(c, scheme_null); + + if (list) + SCHEME_CDR(last) = c; + else + list = c; + + last = c; + form = SCHEME_STX_CDR(form); + + count++; + } + + if (!SCHEME_STX_NULLP(form)) + scheme_wrong_syntax(NULL, form, orig_form, NULL); + + cl = (Scheme_Case_Lambda *) + scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + + (count - 1) * sizeof(Scheme_Object *)); + cl->so.type = scheme_case_lambda_sequence_type; + cl->count = count; + cl->name = SCHEME_TRUEP(name) ? name : NULL; + + scheme_compile_rec_done_local(rec, drec); + recs = MALLOC_N_RT(Scheme_Compile_Info, count); + scheme_init_compile_recs(rec, drec, recs, count); + + for (i = 0; i < count; i++) { + Scheme_Object *ce; + ce = SCHEME_CAR(list); + ce = scheme_compile_expr(ce, env, recs, i); + cl->array[i] = ce; + list = SCHEME_CDR(list); + } + + scheme_merge_compile_recs(rec, drec, recs, count); + + if (scheme_has_method_property(orig_form)) { + Scheme_Closure_Data *data; + /* Make sure no branch has 0 arguments: */ + for (i = 0; i < count; i++) { + data = (Scheme_Closure_Data *)cl->array[i]; + if (!data->num_params) + break; + } + if (i >= count) { + data = (Scheme_Closure_Data *)cl->array[0]; + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_IS_METHOD; + } + } + + return (Scheme_Object *)cl; +} + +static Scheme_Object * +case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *first, *last, *args, *body, *c, *new_line, *orig_form = form; + + SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(erec[drec].observer); + + first = SCHEME_STX_CAR(form); + first = cons(first, scheme_null); + last = first; + form = SCHEME_STX_CDR(form); + + scheme_rec_add_certs(erec, drec, orig_form); + + while (SCHEME_STX_PAIRP(form)) { + Scheme_Object *line_form; + Scheme_Comp_Env *newenv; + + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + + line_form = SCHEME_STX_CAR(form); + + case_lambda_check_line(line_form, orig_form, env); + + body = SCHEME_STX_CDR(line_form); + args = SCHEME_STX_CAR(line_form); + + body = scheme_datum_to_syntax(body, line_form, line_form, 0, 0); + + newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs); + + body = scheme_add_env_renames(body, newenv, env); + args = scheme_add_env_renames(args, newenv, env); + SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(erec[drec].observer, args, body); + + { + Scheme_Expand_Info erec1; + scheme_init_expand_recs(erec, drec, &erec1, 1); + erec1.value_name = scheme_false; + new_line = cons(args, scheme_expand_block(body, newenv, &erec1, 0)); + } + new_line = scheme_datum_to_syntax(new_line, line_form, line_form, 0, 1); + + c = cons(new_line, scheme_null); + + SCHEME_CDR(last) = c; + last = c; + + form = SCHEME_STX_CDR(form); + } + + if (!SCHEME_STX_NULLP(form)) + scheme_wrong_syntax(NULL, form, orig_form, NULL); + + return scheme_datum_to_syntax(first, orig_form, orig_form, 0, 2); +} + +/**********************************************************************/ +/* let, let-values, letrec, etc. */ +/**********************************************************************/ + +static Scheme_Object * +gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, + int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec, + Scheme_Comp_Env *frame_already) +{ + Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname; + int num_clauses, num_bindings, i, j, k, m, pre_k; + Scheme_Comp_Env *frame, *env, *rhs_env; + Scheme_Compile_Info *recs; + Scheme_Object *first = NULL; + Scheme_Compiled_Let_Value *last = NULL, *lv; + DupCheckRecord r; + int rec_env_already = rec[drec].env_already; + int rev_bind_order = recursive; + int post_bind = !recursive && !star; + + i = scheme_stx_proper_list_length(form); + if (i < 3) + scheme_wrong_syntax(NULL, NULL, form, (!i ? "bad syntax (empty body)" : NULL)); + + bindings = SCHEME_STX_CDR(form); + bindings = SCHEME_STX_CAR(bindings); + num_clauses = scheme_stx_proper_list_length(bindings); + + if (num_clauses < 0) + scheme_wrong_syntax(NULL, bindings, form, NULL); + + scheme_rec_add_certs(rec, drec, form); + + forms = SCHEME_STX_CDR(form); + forms = SCHEME_STX_CDR(forms); + forms = scheme_datum_to_syntax(forms, form, form, 0, 0); + + if (!num_clauses) { + env = scheme_no_defines(origenv); + + name = scheme_check_name_property(form, rec[drec].value_name); + rec[drec].value_name = name; + + return scheme_compile_sequence(forms, env, rec, drec); + } + + if (multi) { + num_bindings = 0; + l = bindings; + while (!SCHEME_STX_NULLP(l)) { + Scheme_Object *clause, *names, *rest; + int num_names; + + clause = SCHEME_STX_CAR(l); + + if (!SCHEME_STX_PAIRP(clause)) + rest = NULL; + else { + rest = SCHEME_STX_CDR(clause); + if (!SCHEME_STX_PAIRP(rest)) + rest = NULL; + else { + rest = SCHEME_STX_CDR(rest); + if (!SCHEME_STX_NULLP(rest)) + rest = NULL; + } + } + if (!rest) + scheme_wrong_syntax(NULL, clause, form, NULL); + + names = SCHEME_STX_CAR(clause); + + num_names = scheme_stx_proper_list_length(names); + if (num_names < 0) + scheme_wrong_syntax(NULL, names, form, NULL); + + num_bindings += num_names; + + l = SCHEME_STX_CDR(l); + } + } else + num_bindings = num_clauses; + + + names = MALLOC_N(Scheme_Object *, num_bindings); + if (frame_already) + frame = frame_already; + else { + frame = scheme_new_compilation_frame(num_bindings, + (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), + origenv, + rec[drec].certs); + if (rec_env_already) + frame_already = frame; + } + env = frame; + if (post_bind) + rhs_env = scheme_no_defines(origenv); + else + rhs_env = env; + + recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1)); + + defname = rec[drec].value_name; + scheme_compile_rec_done_local(rec, drec); + scheme_init_compile_recs(rec, drec, recs, num_clauses + 1); + + defname = scheme_check_name_property(form, defname); + + if (!star && !frame_already) { + scheme_begin_dup_symbol_check(&r, env); + } + + /* For `letrec', we bind the first set of identifiers at the deepest + position. That order makes it easier to peel off a prefix into a + separate `letrec'. For `let' and `let*', the first set of + identifiers is at the shallowest position. */ + + if (rev_bind_order) + k = num_bindings; + else + k = 0; + + for (i = 0; i < num_clauses; i++) { + if (!SCHEME_STX_PAIRP(bindings)) + scheme_wrong_syntax(NULL, bindings, form, NULL); + binding = SCHEME_STX_CAR(bindings); + if (!SCHEME_STX_PAIRP(binding) || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(binding))) + scheme_wrong_syntax(NULL, binding, form, NULL); + + { + Scheme_Object *rest; + rest = SCHEME_STX_CDR(binding); + if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) + scheme_wrong_syntax(NULL, binding, form, NULL); + } + + if (rev_bind_order) { + if (multi) { + name = SCHEME_STX_CAR(binding); + while (!SCHEME_STX_NULLP(name)) { + name = SCHEME_STX_CDR(name); + k--; + } + } else + k--; + } + + pre_k = k; + + name = SCHEME_STX_CAR(binding); + if (multi) { + while (!SCHEME_STX_NULLP(name)) { + Scheme_Object *n; + n = SCHEME_STX_CAR(name); + names[k] = n; + scheme_check_identifier(NULL, names[k], NULL, env, form); + k++; + name = SCHEME_STX_CDR(name); + } + + for (j = pre_k; j < k; j++) { + for (m = j + 1; m < k; m++) { + if (scheme_stx_bound_eq(names[m], names[j], scheme_make_integer(env->genv->phase))) + scheme_wrong_syntax(NULL, NULL, form, + "multiple bindings of `%S' in the same clause", + SCHEME_STX_SYM(names[m])); + } + } + } else { + scheme_check_identifier(NULL, name, NULL, env, form); + names[k++] = name; + } + + if (!star && !frame_already) { + for (m = pre_k; m < k; m++) { + scheme_dup_symbol_check(&r, NULL, names[m], "binding", form); + } + } + + lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); + lv->iso.so.type = scheme_compiled_let_value_type; + if (!last) + first = (Scheme_Object *)lv; + else + last->body = (Scheme_Object *)lv; + last = lv; + lv->count = (k - pre_k); + lv->position = pre_k; + + if (lv->count == 1) + recs[i].value_name = SCHEME_STX_SYM(names[pre_k]); + + if (!recursive) { + Scheme_Object *ce, *rhs; + rhs = SCHEME_STX_CDR(binding); + rhs = SCHEME_STX_CAR(rhs); + rhs = scheme_add_env_renames(rhs, env, origenv); + ce = scheme_compile_expr(rhs, rhs_env, recs, i); + lv->value = ce; + } else { + Scheme_Object *rhs; + rhs = SCHEME_STX_CDR(binding); + rhs = SCHEME_STX_CAR(rhs); + lv->value = rhs; + } + + if (star || recursive) { + for (m = pre_k; m < k; m++) { + scheme_add_compilation_binding(m, names[m], frame); + } + } + + bindings = SCHEME_STX_CDR(bindings); + + if (rev_bind_order) + k = pre_k; + } + + if (!star && !recursive) { + for (i = 0; i < num_bindings; i++) { + scheme_add_compilation_binding(i, names[i], frame); + } + } + + if (recursive) { + lv = (Scheme_Compiled_Let_Value *)first; + for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { + Scheme_Object *ce, *rhs; + rhs = lv->value; + rhs = scheme_add_env_renames(rhs, env, origenv); + ce = scheme_compile_expr(rhs, env, recs, i); + lv->value = ce; + + /* Record the fact that this binding doesn't use any or later + bindings in the same set. The `let' optimizer and resolver + break bindings into smaller sets based on this + information. */ + if (!scheme_env_check_reset_any_use(env) + && !scheme_might_invoke_call_cc(ce)) + SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES; + else if (!scheme_env_min_use_below(env, lv->position)) + SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_LATER_USES; + } + } + + recs[num_clauses].value_name = defname ? SCHEME_STX_SYM(defname) : NULL; + { + Scheme_Object *cs; + forms = scheme_add_env_renames(forms, env, origenv); + cs = scheme_compile_sequence(forms, env, recs, num_clauses); + last->body = cs; + } + + /* Save flags: */ + lv = (Scheme_Compiled_Let_Value *)first; + for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { + int *flags; + flags = scheme_env_get_flags(env, lv->position, lv->count); + lv->flags = flags; + } + + { + Scheme_Let_Header *head; + + head = MALLOC_ONE_TAGGED(Scheme_Let_Header); + head->iso.so.type = scheme_compiled_let_void_type; + head->body = first; + head->count = num_bindings; + head->num_clauses = num_clauses; + SCHEME_LET_FLAGS(head) = ((recursive ? SCHEME_LET_RECURSIVE : 0) + | (star ? SCHEME_LET_STAR : 0)); + + first = (Scheme_Object *)head; + } + + scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1); + + return first; +} + +static Scheme_Object * +do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info *erec, int drec, + const char *formname, int letrec, int multi, int letstar, + Scheme_Comp_Env *env_already) +{ + Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname; + Scheme_Comp_Env *use_env, *env; + Scheme_Expand_Info erec1; + DupCheckRecord r; + int rec_env_already = erec[drec].env_already; + + vars = SCHEME_STX_CDR(form); + + if (!SCHEME_STX_PAIRP(vars)) + scheme_wrong_syntax(NULL, NULL, form, NULL); + + body = SCHEME_STX_CDR(vars); + vars = SCHEME_STX_CAR(vars); + + if (!SCHEME_STX_PAIRP(body)) + scheme_wrong_syntax(NULL, NULL, form, (SCHEME_STX_NULLP(body) + ? "bad syntax (empty body)" + : NULL)); + + boundname = scheme_check_name_property(form, erec[drec].value_name); + erec[drec].value_name = boundname; + + scheme_rec_add_certs(erec, drec, form); + + if (letstar) { + if (!SCHEME_STX_NULLP(vars)) { + Scheme_Object *a, *vr; + + if (!SCHEME_STX_PAIRP(vars)) + scheme_wrong_syntax(NULL, vars, form, NULL); + + a = SCHEME_STX_CAR(vars); + vr = SCHEME_STX_CDR(vars); + + first = let_values_symbol; + first = scheme_datum_to_syntax(first, form, scheme_sys_wraps(origenv), 0, 0); + + if (SCHEME_STX_NULLP(vr)) { + /* Don't create redundant empty let form */ + } else { + last = let_star_values_symbol; + last = scheme_datum_to_syntax(last, form, scheme_sys_wraps(origenv), 0, 0); + body = cons(cons(last, cons(vr, body)), + scheme_null); + } + + body = cons(first, + cons(cons(a, scheme_null), + body)); + } else { + first = scheme_datum_to_syntax(let_values_symbol, form, scheme_sys_wraps(origenv), 0, 0); + body = cons(first, cons(scheme_null, body)); + } + + body = scheme_datum_to_syntax(body, form, form, 0, -1); + + first = SCHEME_STX_CAR(form); + body = scheme_stx_track(body, form, first); + + if (erec[drec].depth > 0) + --erec[drec].depth; + + if (!erec[drec].depth) + return body; + else { + env = scheme_no_defines(origenv); + return scheme_expand_expr(body, env, erec, drec); + } + } + + /* Note: no more letstar handling needed after this point */ + if (!env_already && !rec_env_already) + scheme_begin_dup_symbol_check(&r, origenv); + + vlist = scheme_null; + vs = vars; + while (SCHEME_STX_PAIRP(vs)) { + Scheme_Object *v2; + v = SCHEME_STX_CAR(vs); + if (SCHEME_STX_PAIRP(v)) + v2 = SCHEME_STX_CDR(v); + else + v2 = scheme_false; + if (!SCHEME_STX_PAIRP(v2) || !SCHEME_STX_NULLP(SCHEME_STX_CDR(v2))) + scheme_wrong_syntax(NULL, v, form, NULL); + + name = SCHEME_STX_CAR(v); + + { + DupCheckRecord r2; + Scheme_Object *names = name; + if (!env_already && !rec_env_already) + scheme_begin_dup_symbol_check(&r2, origenv); + while (SCHEME_STX_PAIRP(names)) { + name = SCHEME_STX_CAR(names); + + scheme_check_identifier(NULL, name, NULL, origenv, form); + vlist = cons(name, vlist); + + if (!env_already && !rec_env_already) { + scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form); + scheme_dup_symbol_check(&r, NULL, name, "binding", form); + } + + names = SCHEME_STX_CDR(names); + } + if (!SCHEME_STX_NULLP(names)) + scheme_wrong_syntax(NULL, names, form, NULL); + } + + vs = SCHEME_STX_CDR(vs); + } + + if (!SCHEME_STX_NULLP(vs)) + scheme_wrong_syntax(NULL, vs, form, NULL); + + if (env_already) + env = env_already; + else + env = scheme_add_compilation_frame(vlist, + origenv, + (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), + erec[drec].certs); + + if (letrec) + use_env = env; + else + use_env = scheme_no_defines(origenv); + + /* Pass 1: Rename */ + + first = last = NULL; + vs = vars; + while (SCHEME_STX_PAIRP(vars)) { + Scheme_Object *rhs; + + v = SCHEME_STX_CAR(vars); + + /* Make sure names gets their own renames: */ + name = SCHEME_STX_CAR(v); + name = scheme_add_env_renames(name, env, origenv); + + rhs = SCHEME_STX_CDR(v); + rhs = SCHEME_STX_CAR(rhs); + rhs = scheme_add_env_renames(rhs, use_env, origenv); + + v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); + v = cons(v, scheme_null); + + if (!first) + first = v; + else + SCHEME_CDR(last) = v; + + last = v; + vars = SCHEME_STX_CDR(vars); + } + if (!first) { + first = scheme_null; + } + vars = first; + + body = scheme_datum_to_syntax(body, form, form, 0, 0); + body = scheme_add_env_renames(body, env, origenv); + SCHEME_EXPAND_OBSERVE_LET_RENAMES(erec[drec].observer, vars, body); + + /* Pass 2: Expand */ + + first = last = NULL; + while (SCHEME_STX_PAIRP(vars)) { + Scheme_Object *rhs, *rhs_name; + + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + + v = SCHEME_STX_CAR(vars); + + name = SCHEME_STX_CAR(v); + rhs = SCHEME_STX_CDR(v); + rhs = SCHEME_STX_CAR(rhs); + + if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) { + rhs_name = SCHEME_STX_CAR(name); + } else { + rhs_name = scheme_false; + } + + scheme_init_expand_recs(erec, drec, &erec1, 1); + erec1.value_name = rhs_name; + rhs = scheme_expand_expr(rhs, use_env, &erec1, 0); + + v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); + v = cons(v, scheme_null); + + if (!first) + first = v; + else + SCHEME_CDR(last) = v; + + last = v; + + vars = SCHEME_STX_CDR(vars); + } + + /* End Pass 2 */ + + if (!SCHEME_STX_NULLP(vars)) + scheme_wrong_syntax(NULL, vars, form, NULL); + + if (!first) + first = scheme_null; + + first = scheme_datum_to_syntax(first, vs, vs, 0, 1); + + SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer); + scheme_init_expand_recs(erec, drec, &erec1, 1); + erec1.value_name = erec[drec].value_name; + body = scheme_expand_block(body, env, &erec1, 0); + + v = SCHEME_STX_CAR(form); + v = cons(v, cons(first, body)); + v = scheme_datum_to_syntax(v, form, form, 0, 2); + + return v; +} + +static Scheme_Object * +let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(erec[drec].observer); + return do_let_expand(form, env, erec, drec, "let-values", 0, 1, 0, NULL); +} + +static Scheme_Object * +let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(erec[drec].observer); + return do_let_expand(form, env, erec, drec, "let*-values", 0, 1, 1, NULL); +} + +static Scheme_Object * +letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(erec[drec].observer); + return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, 0, NULL); +} + + +static Scheme_Object * +let_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return gen_let_syntax(form, env, "let-values", 0, 0, 1, rec, drec, NULL); +} + +static Scheme_Object * +let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return gen_let_syntax(form, env, "let*-values", 1, 0, 1, rec, drec, NULL); +} + +static Scheme_Object * +letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + return gen_let_syntax(form, env, "letrec-values", 0, 1, 1, rec, drec, NULL); +} + +/**********************************************************************/ +/* begin, begin0, implicit begins */ +/**********************************************************************/ + +Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, + Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ +#if 0 + /* This attempt at a shortcut is wrong, because the sole expression might expand + to a `begin' that needs to be spliced into an internal-definition context. */ + try_again: + + if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { + /* If it's a begin, we have to check some more... */ + Scheme_Object *first, *val; + + first = SCHEME_STX_CAR(forms); + first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL); + + if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) { + /* Flatten begin: */ + if (scheme_stx_proper_list_length(first) > 1) { + Scheme_Object *rest; + rest = scheme_flatten_begin(first, scheme_null); + first = scheme_datum_to_syntax(rest, first, first, 0, 2); + forms = first; + goto try_again; + } + } + + return scheme_compile_expr(first, env, rec, drec); + } +#endif + + if (scheme_stx_proper_list_length(forms) < 0) { + scheme_wrong_syntax(scheme_begin_stx_string, NULL, + scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), + "bad syntax (" IMPROPER_LIST_FORM ")"); + return NULL; + } else { + Scheme_Object *body; + body = scheme_compile_block(forms, env, rec, drec); + return scheme_make_sequence_compilation(body, 1); + } +} + +Scheme_Object *scheme_compiled_void() +{ + return scheme_void; +} + +static Scheme_Object * +do_begin_syntax(char *name, + Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, + int zero) +{ + Scheme_Object *forms, *body; + + forms = SCHEME_STX_CDR(form); + + if (SCHEME_STX_NULLP(forms)) { + if (!zero && scheme_is_toplevel(env)) + return scheme_compiled_void(); + scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)"); + return NULL; + } + + check_form(form, form); + + if (zero) + env = scheme_no_defines(env); + + if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { + scheme_rec_add_certs(rec, drec, form); + forms = SCHEME_STX_CAR(forms); + return scheme_compile_expr(forms, env, rec, drec); + } + + if (!scheme_is_toplevel(env)) { + /* Not at top-level */ + if (zero) { + /* First expression is not part of the block: */ + Scheme_Compile_Info recs[2]; + Scheme_Object *first, *rest, *vname; + + vname = rec[drec].value_name; + scheme_compile_rec_done_local(rec, drec); + + vname = scheme_check_name_property(form, vname); + + scheme_rec_add_certs(rec, drec, form); + + scheme_init_compile_recs(rec, drec, recs, 2); + recs[0].value_name = vname; + + first = SCHEME_STX_CAR(forms); + first = scheme_compile_expr(first, env, recs, 0); + rest = SCHEME_STX_CDR(forms); + rest = scheme_compile_list(rest, env, recs, 1); + + scheme_merge_compile_recs(rec, drec, recs, 2); + + body = cons(first, rest); + } else { + Scheme_Object *v; + v = scheme_check_name_property(form, rec[drec].value_name); + rec[drec].value_name = v; + scheme_rec_add_certs(rec, drec, form); + + body = scheme_compile_list(forms, env, rec, drec); + } + } else { + /* Top level */ + scheme_rec_add_certs(rec, drec, form); + body = scheme_compile_list(forms, env, rec, drec); + } + + forms = scheme_make_sequence_compilation(body, zero ? -1 : 1); + + if (!zero + && SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type) + && scheme_is_toplevel(env)) { + forms->type = scheme_splice_sequence_type; + return forms; + } + + return forms; +} + +static Scheme_Object * +begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + return do_begin_syntax("begin", form, env, rec, drec, 0); +} + +static Scheme_Object * +begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + return do_begin_syntax("begin0", form, env, rec, drec, 1); +} + +Scheme_Sequence *scheme_malloc_sequence(int count) +{ + return (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence) + + (count - 1) + * sizeof(Scheme_Object *)); +} + +Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) +{ + /* We have to be defensive in processing `seq'; it might be bad due + to a bad .zo */ + Scheme_Object *list, *v, *good; + Scheme_Sequence *o; + int count, i, k, total, last, first, setgood, addconst; + Scheme_Type type; + + type = scheme_sequence_type; + + list = seq; + count = i = 0; + good = NULL; + total = 0; + first = 1; + setgood = 1; + while (SCHEME_PAIRP(list)) { + v = SCHEME_CAR(list); + list = SCHEME_CDR(list); + last = SCHEME_NULLP(list); + + if (((opt > 0) || !first) && SAME_TYPE(SCHEME_TYPE(v), type)) { + /* "Inline" nested begins */ + count += ((Scheme_Sequence *)v)->count; + total++; + } else if (opt + && (((opt > 0) && !last) || ((opt < 0) && !first)) + && scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) { + /* A value that is not the result. We'll drop it. */ + total++; + } else { + if (setgood) + good = v; + count++; + total++; + } + i++; + if (first) { + if (opt < 0) + setgood = 0; + first = 0; + } + } + + if (!SCHEME_NULLP(list)) + return NULL; /* bad .zo */ + + if (!count) + return scheme_compiled_void(); + + if (count == 1) { + if (opt < -1) { + /* can't optimize away a begin0 at read time; it's too late, since the + return is combined with EXPD_BEGIN0 */ + addconst = 1; + } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, -1)) { + /* We can't optimize (begin0 expr cont) to expr because + exp is not in tail position in the original (so we'd mess + up continuation marks). */ + addconst = 1; + } else + return good; + } else + addconst = 0; + + o = scheme_malloc_sequence(count + addconst); + + o->so.type = ((opt < 0) ? scheme_begin0_sequence_type : scheme_sequence_type); + o->count = count + addconst; + + --total; + for (i = k = 0; i < count; k++) { + v = SCHEME_CAR(seq); + seq = SCHEME_CDR(seq); + + if (((opt > 0) || k) && SAME_TYPE(SCHEME_TYPE(v), type)) { + int c, j; + Scheme_Object **a; + + c = ((Scheme_Sequence *)v)->count; + a = ((Scheme_Sequence *)v)->array; /* <-- mismaligned for precise GC */ + for (j = 0; j < c; j++) { + o->array[i++] = a[j]; + } + } else if (opt + && (((opt > 0) && (k < total)) + || ((opt < 0) && k)) + && scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) { + /* Value not the result. Do nothing. */ + } else + o->array[i++] = v; + } + + if (addconst) + o->array[i] = scheme_make_integer(0); + + return (Scheme_Object *)o; +} + +static Scheme_Object * +stratified_body_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *body; + + check_form(form, form); + + body = SCHEME_STX_CDR(form); + body = scheme_datum_to_syntax(body, form, form, 0, 0); + + body = scheme_compile_stratified_block(body, env, rec, drec); + + if (SCHEME_NULLP(SCHEME_CDR(body))) + return SCHEME_CAR(body); + else + return scheme_make_sequence_compilation(body, 1); +} + +static Scheme_Object * +do_begin_expand(char *name, + Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, + int zero) +{ + Scheme_Object *form_name; + Scheme_Object *rest; + Scheme_Object *orig_form = form; + + check_form(form, form); + + form_name = SCHEME_STX_CAR(form); + + rest = SCHEME_STX_CDR(form); + + if (SCHEME_STX_NULLP(rest)) { + if (!zero && scheme_is_toplevel(env)) { + SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form); + SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form); + return form; + } + scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)"); + return NULL; + } + + if (zero) + env = scheme_no_defines(env); + + if (!scheme_is_toplevel(env)) { + /* Not at top-level: */ + if (zero) { + Scheme_Object *fst, *boundname; + Scheme_Expand_Info erec1; + scheme_rec_add_certs(erec, drec, form); + scheme_init_expand_recs(erec, drec, &erec1, 1); + boundname = scheme_check_name_property(form, erec[drec].value_name); + erec1.value_name = boundname; + erec[drec].value_name = scheme_false; + fst = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); + + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + fst = scheme_expand_expr(fst, env, &erec1, 0); + rest = scheme_datum_to_syntax(rest, form, form, 0, 0); + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + rest = scheme_expand_list(rest, env, erec, drec); + + form = cons(fst, rest); + } else { + Scheme_Object *boundname; + boundname = scheme_check_name_property(form, erec[drec].value_name); + erec[drec].value_name = boundname; + scheme_rec_add_certs(erec, drec, form); + + form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), + env, erec, drec); +#if 0 + if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) + return SCHEME_STX_CAR(form); +#endif + } + } else { + /* Top level */ + scheme_rec_add_certs(erec, drec, form); + form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), + env, erec, drec); + } + + return scheme_datum_to_syntax(cons(form_name, form), + orig_form, orig_form, + 0, 2); +} + +static Scheme_Object * +begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(erec[drec].observer); + return do_begin_expand("begin", form, env, erec, drec, 0); +} + +static Scheme_Object * +begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(erec[drec].observer); + return do_begin_expand("begin0", form, env, erec, drec, 1); +} + +static Scheme_Object * +stratified_body_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *body; + + SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(erec[drec].observer); + + check_form(form, form); + + body = SCHEME_STX_CDR(form); + body = scheme_datum_to_syntax(body, form, form, 0, 0); + + body = scheme_expand_stratified_block(body, env, erec, drec); + + if (SCHEME_STX_NULLP(SCHEME_STX_CDR(body))) + return SCHEME_STX_CAR(body); + else { + body = cons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), + body); + return scheme_datum_to_syntax(body, form, form, 0, 0); + } +} + +/**********************************************************************/ +/* #%non-module and #%expression */ +/**********************************************************************/ + +static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_only) +{ + Scheme_Object *rest; + + check_form(form, form); + + rest = SCHEME_STX_CDR(form); + if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) + scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)"); + + if (top_only && !scheme_is_toplevel(top_only)) + scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); + + return SCHEME_STX_CAR(rest); +} + +static Scheme_Object * +single_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only) +{ + scheme_rec_add_certs(rec, drec, form); + return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec); +} + +static Scheme_Object * +single_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, + int top_only, int simplify) +{ + Scheme_Object *expr, *form_name; + + scheme_rec_add_certs(erec, drec, form); + + expr = check_single(form, top_only ? env : NULL); + expr = scheme_expand_expr(expr, env, erec, drec); + + form_name = SCHEME_STX_CAR(form); + + if (simplify && (erec[drec].depth == -1)) { + /* FIXME: this needs EXPAND_OBSERVE callbacks. */ + expr = scheme_stx_track(expr, form, form_name); + expr = scheme_stx_cert(expr, scheme_false, NULL, form, NULL, 1); + SCHEME_EXPAND_OBSERVE_TAG(erec[drec].observer,expr); + return expr; + } + + return scheme_datum_to_syntax(cons(form_name, cons(expr, scheme_null)), + form, form, + 0, 2); +} + +static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + return single_syntax(form, scheme_no_defines(env), rec, drec, 0); +} + +static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(erec[drec].observer); + return single_expand(form, scheme_no_defines(env), erec, drec, 0, + !(env->flags & SCHEME_TOPLEVEL_FRAME)); +} + + +/**********************************************************************/ +/* unquote, unquote-splicing */ +/**********************************************************************/ + +static Scheme_Object * +unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + int len; + + if (rec[drec].comp) + scheme_compile_rec_done_local(rec, drec); + + len = check_form(form, form); + if (len != 2) + bad_form(form, len); + + scheme_wrong_syntax(NULL, NULL, form, "not in quasiquote"); + return NULL; +} + +static Scheme_Object * +unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + return unquote_syntax(form, env, erec, drec); +} + +/**********************************************************************/ +/* quote-syntax */ +/**********************************************************************/ + +static Scheme_Object * +quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + int len; + Scheme_Object *stx; + + if (rec[drec].comp) + scheme_compile_rec_done_local(rec, drec); + + len = check_form(form, form); + if (len != 2) + bad_form(form, len); + + scheme_rec_add_certs(rec, drec, form); + + stx = SCHEME_STX_CDR(form); + stx = SCHEME_STX_CAR(stx); + + /* Push all certificates in the environment down to the syntax object. */ + stx = scheme_stx_add_inactive_certs(stx, rec[drec].certs); + if (env->genv->module && !rec[drec].no_module_cert) { + /* Also certify access to the enclosing module: */ + stx = scheme_stx_cert(stx, scheme_false, env->genv, NULL, NULL, 0); + } + + if (rec[drec].comp) { + return scheme_register_stx_in_prefix(stx, env, rec, drec); + } else { + Scheme_Object *fn; + fn = SCHEME_STX_CAR(form); + return scheme_datum_to_syntax(cons(fn, cons(stx, scheme_null)), + form, + form, + 0, 2); + } +} + +static Scheme_Object * +quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(erec[drec].observer); + return quote_syntax_syntax(form, env, erec, drec); +} + + +/**********************************************************************/ +/* define-syntaxes */ +/**********************************************************************/ + +static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) +{ + Scheme_Env *env = (Scheme_Env *)_env; + + return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL); +} + +static Scheme_Object * +do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec, int for_stx) +{ + Scheme_Object *names, *code, *dummy; + Scheme_Object *val, *vec; + Scheme_Comp_Env *exp_env; + Scheme_Compile_Info rec1; + + scheme_compile_rec_done_local(rec, drec); + scheme_default_compile_rec(rec, drec); + scheme_rec_add_certs(rec, drec, form); + + scheme_define_parse(form, &names, &code, 1, env, 0); + + scheme_prepare_exp_env(env->genv); + scheme_prepare_compile_env(env->genv->exp_env); + + if (!for_stx) + names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv); + + exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); + + dummy = scheme_make_environment_dummy(env); + + rec1.comp = 1; + rec1.dont_mark_local_use = 0; + rec1.resolve_module_ids = 0; + rec1.no_module_cert = 0; + rec1.value_name = NULL; + rec1.certs = rec[drec].certs; + rec1.observer = NULL; + rec1.pre_unwrapped = 0; + rec1.env_already = 0; + rec1.comp_flags = rec[drec].comp_flags; + + if (for_stx) { + names = defn_targets_syntax(names, exp_env, &rec1, 0); + scheme_compile_rec_done_local(&rec1, 0); + } + + val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0); + + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)exp_env->prefix; + SCHEME_VEC_ELS(vec)[1] = dummy; + SCHEME_VEC_ELS(vec)[2] = names; + SCHEME_VEC_ELS(vec)[3] = val; + + vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + + return vec; +} + +static Scheme_Object * +define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return do_define_syntaxes_syntax(form, env, rec, drec, 0); +} + +static Scheme_Object * +define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return do_define_syntaxes_syntax(form, env, rec, drec, 1); +} + +static Scheme_Object * +define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *names, *code, *fpart, *fn; + + SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer); + + scheme_prepare_exp_env(env->genv); + scheme_prepare_compile_env(env->genv->exp_env); + + scheme_define_parse(form, &names, &code, 1, env, 0); + + env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0); + + scheme_rec_add_certs(erec, drec, form); + erec[drec].value_name = names; + fpart = scheme_expand_expr_lift_to_let(code, env, erec, drec); + + code = cons(fpart, scheme_null); + code = cons(names, code); + + fn = SCHEME_STX_CAR(form); + return scheme_datum_to_syntax(cons(fn, code), + form, form, + 0, 2); +} + +static Scheme_Object * +define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + return define_syntaxes_expand(form, env, erec, drec); +} + +Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env) +{ + /* Get a prefixed-based accessor for a dummy top-level bucket. It's + used to "link" to the right environment at run time. The #f as + a toplevel is handled in the prefix linker specially. */ + return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0, 0); +} + +Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy) +{ + Scheme_Prefix *toplevels; + Scheme_Bucket *b; + + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(dummy)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(dummy)]; + return scheme_get_bucket_home(b); +} + +/**********************************************************************/ +/* letrec-syntaxes */ +/**********************************************************************/ + +static void *eval_letmacro_rhs_k(void); + +static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_env, + int max_let_depth, Resolve_Prefix *rp, + int phase, Scheme_Object *certs) +{ + Scheme_Object **save_runstack; + int depth; + + depth = max_let_depth + scheme_prefix_depth(rp); + if (!scheme_check_runstack(depth)) { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = a; + p->ku.k.p2 = rhs_env; + p->ku.k.p3 = rp; + p->ku.k.p4 = certs; + p->ku.k.i1 = max_let_depth; + p->ku.k.i2 = phase; + return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k); + } + + save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv); + + if (scheme_omittable_expr(a, 1, -1, 0, NULL, -1)) { + /* short cut */ + a = _scheme_eval_linked_expr_multi(a); + } else { + Scheme_Cont_Frame_Data cframe; + Scheme_Config *config; + Scheme_Dynamic_State dyn_state; + + scheme_prepare_exp_env(rhs_env->genv); + scheme_prepare_compile_env(rhs_env->genv->exp_env); + + config = scheme_extend_config(scheme_current_config(), + MZCONFIG_ENV, + (Scheme_Object *)rhs_env->genv->exp_env); + scheme_push_continuation_frame(&cframe); + scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); + + scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, certs, rhs_env->genv, rhs_env->genv->link_midx); + a = scheme_eval_linked_expr_multi_with_dynamic_state(a, &dyn_state); + + scheme_pop_continuation_frame(&cframe); + } + + scheme_pop_prefix(save_runstack); + + return a; +} + +static void *eval_letmacro_rhs_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *a, *certs; + Scheme_Comp_Env *rhs_env; + int max_let_depth, phase; + Resolve_Prefix *rp; + + a = (Scheme_Object *)p->ku.k.p1; + rhs_env = (Scheme_Comp_Env *)p->ku.k.p2; + rp = (Resolve_Prefix *)p->ku.k.p3; + certs = (Scheme_Object *)p->ku.k.p4; + max_let_depth = p->ku.k.i1; + phase = p->ku.k.i2; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + p->ku.k.p4 = NULL; + + return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase, certs); +} + +void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, + Scheme_Env *exp_env, Scheme_Object *insp, + Scheme_Compile_Expand_Info *rec, int drec, + Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, + int *_pos, Scheme_Object *rename_rib) +{ + Scheme_Object **results, *l, *a_expr; + Scheme_Comp_Env *eenv; + Scheme_Object *certs; + Resolve_Prefix *rp; + Resolve_Info *ri; + Optimize_Info *oi; + int vc, nc, j, i; + Scheme_Compile_Expand_Info mrec; + + certs = rec[drec].certs; + eenv = scheme_new_comp_env(exp_env, insp, 0); + + /* First expand for expansion-observation */ + if (!rec[drec].comp) { + scheme_init_expand_recs(rec, drec, &mrec, 1); + SCHEME_EXPAND_OBSERVE_ENTER_BIND(rec[drec].observer); + a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0); + } + + /* Then compile */ + mrec.comp = 1; + mrec.dont_mark_local_use = 0; + mrec.resolve_module_ids = 1; + mrec.no_module_cert = 1; + mrec.value_name = NULL; + mrec.certs = certs; + mrec.observer = NULL; + mrec.pre_unwrapped = 0; + mrec.env_already = 0; + mrec.comp_flags = rec[drec].comp_flags; + + a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0); + + /* For internal defn, don't simplify as resolving, because the + expression may have syntax objects with a lexical rename that + is still being extended. + For letrec-syntaxes+values, don't simplify because it's too expensive. */ + rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, 0); + + oi = scheme_optimize_info_create(); + if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) + scheme_optimize_info_never_inline(oi); + a = scheme_optimize_expr(a, oi, 0); + + ri = scheme_resolve_info_create(rp); + a = scheme_resolve_expr(a, ri); + + rp = scheme_remap_prefix(rp, ri); + + /* To JIT: + if (ri->use_jit) a = scheme_jit_expr(a); + but it's not likely that a let-syntax-bound macro is going + to run lots of times, so JITting is probably not worth it. */ + + SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); + + a_expr = a; + a = eval_letmacro_rhs(a_expr, rhs_env, + scheme_resolve_info_max_let_depth(ri), + rp, eenv->genv->phase, certs); + + if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) { + vc = scheme_current_thread->ku.multiple.count; + results = scheme_current_thread->ku.multiple.array; + scheme_current_thread->ku.multiple.array = NULL; + if (SAME_OBJ(results, scheme_current_thread->values_buffer)) + scheme_current_thread->values_buffer = NULL; + } else { + vc = 1; + results = NULL; + } + + for (nc = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + nc++; + } + + if (vc != nc) { + Scheme_Object *name; + const char *symname; + + if (nc >= 1) { + name = SCHEME_STX_CAR(names); + name = SCHEME_STX_VAL(name); + } else + name = NULL; + symname = (name ? scheme_symbol_name(name) : ""); + + scheme_wrong_return_arity(where, + nc, vc, + (vc == 1) ? (Scheme_Object **)a : results, + "%s%s%s", + name ? "defining \"" : "0 names", + symname, + name ? ((nc == 1) ? "\"" : "\", ...") : ""); + } + + i = *_pos; + for (j = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l), j++) { + Scheme_Object *name, *macro; + name = SCHEME_STX_CAR(l); + + macro = scheme_alloc_small_object(); + macro->type = scheme_macro_type; + if (vc == 1) + SCHEME_PTR_VAL(macro) = a; + else + SCHEME_PTR_VAL(macro) = results[j]; + + scheme_set_local_syntax(i++, name, macro, stx_env); + + if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { + /* Install a free-id=? rename */ + scheme_install_free_id_rename(name, scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), rename_rib, + scheme_make_integer(rhs_env->genv->phase)); + } + } + *_pos = i; + + SCHEME_EXPAND_OBSERVE_EXIT_BIND(rec[drec].observer); +} + +static Scheme_Object * +do_letrec_syntaxes(const char *where, + Scheme_Object *forms, Scheme_Comp_Env *origenv, + Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *form, *bindings, *var_bindings, *body, *v; + Scheme_Object *names_to_disappear; + Scheme_Comp_Env *stx_env, *var_env, *rhs_env; + int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already; + DupCheckRecord r; + + env_already = rec[drec].env_already; + + form = SCHEME_STX_CDR(forms); + if (!SCHEME_STX_PAIRP(form)) + scheme_wrong_syntax(NULL, NULL, forms, NULL); + bindings = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + if (!SCHEME_STX_PAIRP(form)) + scheme_wrong_syntax(NULL, NULL, forms, NULL); + var_bindings = SCHEME_STX_CAR(form); + form = SCHEME_STX_CDR(form); + if (!SCHEME_STX_PAIRP(form)) + scheme_wrong_syntax(NULL, NULL, forms, NULL); + body = scheme_datum_to_syntax(form, forms, forms, 0, 0); + + scheme_rec_add_certs(rec, drec, forms); + + if (env_already) + stx_env = origenv; + else + stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs); + + rhs_env = stx_env; + + if (!SCHEME_STX_NULLP(bindings) && !SCHEME_STX_PAIRP(bindings)) { + scheme_wrong_syntax(NULL, bindings, forms, "bad syntax (not a binding sequence)"); + } else + check_form(bindings, forms); + if (!SCHEME_STX_NULLP(var_bindings) && !SCHEME_STX_PAIRP(var_bindings)) { + scheme_wrong_syntax(NULL, var_bindings, forms, "bad syntax (not a binding sequence)"); + } else + check_form(var_bindings, forms); + + cnt = stx_cnt = var_cnt = 0; + saw_var = 0; + + depth = rec[drec].depth; + + if (!rec[drec].comp && (depth <= 0) && (depth > -2)) + names_to_disappear = scheme_null; + else + names_to_disappear = NULL; + + if (!env_already) + scheme_begin_dup_symbol_check(&r, stx_env); + + /* Pass 1: Check and Rename */ + + for (i = 0; i < 2 ; i++) { + for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { + Scheme_Object *a, *l; + + a = SCHEME_STX_CAR(v); + if (!SCHEME_STX_PAIRP(a) + || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(a))) + v = NULL; + else { + for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l))) + break; + } + if (!SCHEME_STX_NULLP(l)) + v = NULL; + } + + if (v) { + Scheme_Object *rest; + rest = SCHEME_STX_CDR(a); + if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) + v = NULL; + } + + if (!v) + scheme_wrong_syntax(NULL, a, forms, + "bad syntax (binding clause not an identifier sequence and expression)"); + + for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + if (!env_already) { + scheme_check_identifier(where, a, NULL, stx_env, forms); + scheme_dup_symbol_check(&r, where, a, "binding", forms); + } + cnt++; + } + if (i) + saw_var = 1; + } + + if (!i) + stx_cnt = cnt; + else + var_cnt = cnt - stx_cnt; + } + + if (!env_already) + scheme_add_local_syntax(stx_cnt, stx_env); + + if (saw_var) { + var_env = scheme_new_compilation_frame(var_cnt, + (env_already ? SCHEME_INTDEF_SHADOW : 0), + stx_env, + rec[drec].certs); + } else + var_env = NULL; + + for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) { + cnt = (i ? var_cnt : stx_cnt); + if (cnt > 0) { + /* Add new syntax/variable names to the environment: */ + if (i) { + /* values in reverse order across clauses, in order within a clause */ + j = var_cnt; + } else + j = 0; + for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { + Scheme_Object *a, *l; + int pre_j; + + if (i) { + a = SCHEME_STX_CAR(v); + for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + j--; + } + pre_j = j; + } else + pre_j = 0; + + a = SCHEME_STX_CAR(v); + for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + if (i) { + /* In compile mode, this will get re-written by the letrec compiler. + But that's ok. We need it now for env_renames. */ + scheme_add_compilation_binding(j++, a, var_env); + } else + scheme_set_local_syntax(j++, a, NULL, stx_env); + } + + if (i) j = pre_j; + } + } + } + + if (names_to_disappear) { + for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { + Scheme_Object *a, *names; + + a = SCHEME_STX_CAR(v); + names = SCHEME_STX_CAR(a); + while (!SCHEME_STX_NULLP(names)) { + a = SCHEME_STX_CAR(names); + if (names_to_disappear) + names_to_disappear = cons(a, names_to_disappear); + names = SCHEME_STX_CDR(names); + } + } + } + + bindings = scheme_add_env_renames(bindings, stx_env, origenv); + if (var_env) + bindings = scheme_add_env_renames(bindings, var_env, origenv); + if (var_env) + var_bindings = scheme_add_env_renames(var_bindings, stx_env, origenv); + + body = scheme_add_env_renames(body, stx_env, origenv); + SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body); + + scheme_prepare_exp_env(stx_env->genv); + scheme_prepare_compile_env(stx_env->genv->exp_env); + + if (!env_already) { + i = 0; + + for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { + Scheme_Object *a, *names; + + SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); + + a = SCHEME_STX_CAR(v); + names = SCHEME_STX_CAR(a); + a = SCHEME_STX_CDR(a); + a = SCHEME_STX_CAR(a); + + scheme_bind_syntaxes(where, names, a, + stx_env->genv->exp_env, + stx_env->insp, + rec, drec, + stx_env, rhs_env, + &i, NULL); + } + } + + SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer); + + if (!env_already && names_to_disappear) { + /* Need to add renaming for disappeared bindings. If they + originated for internal definitions, then we need both + pre-renamed and renamed, since some might have been + expanded to determine definitions. */ + Scheme_Object *l, *a, *pf = NULL, *pl = NULL; + + if (origenv->flags & SCHEME_FOR_INTDEF) { + for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + a = cons(a, scheme_null); + if (pl) + SCHEME_CDR(pl) = a; + else + pf = a; + pl = a; + } + } + + for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + a = scheme_add_env_renames(a, stx_env, origenv); + SCHEME_CAR(l) = a; + } + + if (pf) { + SCHEME_CDR(pl) = names_to_disappear; + names_to_disappear = pf; + } + } + + if (!var_env) { + var_env = scheme_require_renames(stx_env); + if (rec[drec].comp) { + v = scheme_check_name_property(forms, rec[drec].value_name); + rec[drec].value_name = v; + v = scheme_compile_block(body, var_env, rec, drec); + v = scheme_make_sequence_compilation(v, 1); + } else { + v = scheme_expand_block(body, var_env, rec, drec); + if ((depth >= 0) || (depth == -2)) { + Scheme_Object *formname; + formname = SCHEME_STX_CAR(forms); + v = cons(formname, cons(bindings, cons(var_bindings, v))); + } else { + v = cons(let_values_symbol, cons(scheme_null, v)); + } + + if (SCHEME_PAIRP(v)) + v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), + 0, 2); + + if (!((depth >= 0) || (depth == -2))) { + SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v); + } + } + } else { + /* Construct letrec-values expression: */ + v = cons(letrec_values_symbol, cons(var_bindings, body)); + v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2); + + if (rec[drec].comp) { + v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env); + } else { + SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(rec[drec].observer); + v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env); + + if ((depth >= 0) || (depth == -2)) { + /* Pull back out the pieces we want: */ + Scheme_Object *formname; + formname = SCHEME_STX_CAR(forms); + v = SCHEME_STX_CDR(v); + v = cons(formname, cons(bindings, v)); + v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2); + } else { + SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v); + } + } + } + + /* Add the 'disappeared-binding property */ + if (names_to_disappear) + v = scheme_stx_property(v, disappeared_binding_symbol, names_to_disappear); + + return v; +} + +static Scheme_Object * +letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return do_letrec_syntaxes("letrec-syntaxes+values", form, env, rec, drec); +} + +static Scheme_Object * +letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(erec[drec].observer); + + return do_letrec_syntaxes("letrec-syntaxes+values", form, env, erec, drec); +} + +/*========================================================================*/ +/* applications */ +/*========================================================================*/ + +int scheme_get_eval_type(Scheme_Object *obj) + /* Categories for short-cutting recursive calls to the evaluator */ +{ + Scheme_Type type; + + type = SCHEME_TYPE(obj); + + if (type > _scheme_values_types_) + return SCHEME_EVAL_CONSTANT; + else if (SAME_TYPE(type, scheme_local_type)) + return SCHEME_EVAL_LOCAL; + else if (SAME_TYPE(type, scheme_local_unbox_type)) + return SCHEME_EVAL_LOCAL_UNBOX; + else if (SAME_TYPE(type, scheme_toplevel_type)) + return SCHEME_EVAL_GLOBAL; + else + return SCHEME_EVAL_GENERAL; +} + +Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Scheme_Object *context) + /* Apply `f' to `args' and ignore failues --- used for constant + folding attempts */ +{ + Scheme_Object * volatile result; + Scheme_Object * volatile exn = NULL; + mz_jmp_buf *savebuf, newbuf; + + scheme_current_thread->reading_delayed = NULL; + scheme_current_thread->constant_folding = (context ? context : scheme_true); + savebuf = scheme_current_thread->error_buf; + scheme_current_thread->error_buf = &newbuf; + + if (scheme_setjmp(newbuf)) { + result = NULL; + exn = scheme_current_thread->reading_delayed; + } else + result = _scheme_apply_to_list(f, args); + + scheme_current_thread->error_buf = savebuf; + scheme_current_thread->constant_folding = NULL; + scheme_current_thread->reading_delayed = NULL; + + if (scheme_current_thread->cjs.is_kill) { + scheme_longjmp(*scheme_current_thread->error_buf, 1); + } + + if (exn) + scheme_raise(exn); + + return result; +} + +static int foldable_body(Scheme_Object *f) +{ + Scheme_Closure_Data *d; + + d = SCHEME_COMPILED_CLOS_CODE(f); + + scheme_delay_load_closure(d); + + return (SCHEME_TYPE(d->code) > _scheme_values_types_); +} + +Scheme_Object *scheme_make_application(Scheme_Object *v) +{ + Scheme_Object *o; + int i, nv; + volatile int n; + + o = v; + n = 0; + nv = 0; + while (!SCHEME_NULLP(o)) { + Scheme_Type type; + + n++; + type = SCHEME_TYPE(SCHEME_CAR(o)); + if (type < _scheme_compiled_values_types_) + nv = 1; + o = SCHEME_CDR(o); + } + + if (!nv) { + /* They're all values. Applying folding prim or closure? */ + Scheme_Object *f; + + f = SCHEME_CAR(v); + + if ((SCHEME_PRIMP(f) && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) + == SCHEME_PRIM_OPT_FOLDING)) + || (SCHEME_CLSD_PRIMP(f) + && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) + == SCHEME_PRIM_OPT_FOLDING)) + || (SAME_TYPE(SCHEME_TYPE(f), scheme_closure_type) + && (foldable_body(f)))) { + f = scheme_try_apply(f, SCHEME_CDR(v), scheme_false); + + if (f) + return f; + } + } + + if (n == 2) { + Scheme_App2_Rec *app; + + app = MALLOC_ONE_TAGGED(Scheme_App2_Rec); + app->iso.so.type = scheme_application2_type; + + app->rator = SCHEME_CAR(v); + v = SCHEME_CDR(v); + app->rand = SCHEME_CAR(v); + + return (Scheme_Object *)app; + } else if (n == 3) { + Scheme_App3_Rec *app; + + app = MALLOC_ONE_TAGGED(Scheme_App3_Rec); + app->iso.so.type = scheme_application3_type; + + app->rator = SCHEME_CAR(v); + v = SCHEME_CDR(v); + app->rand1 = SCHEME_CAR(v); + v = SCHEME_CDR(v); + app->rand2 = SCHEME_CAR(v); + + return (Scheme_Object *)app; + } else { + Scheme_App_Rec *app; + + app = scheme_malloc_application(n); + + for (i = 0; i < n; i++, v = SCHEME_CDR(v)) { + app->args[i] = SCHEME_CAR(v); + } + + return (Scheme_Object *)app; + } +} + +Scheme_App_Rec *scheme_malloc_application(int n) +{ + Scheme_App_Rec *app; + int size; + + size = (sizeof(Scheme_App_Rec) + + ((n - 1) * sizeof(Scheme_Object *)) + + n * sizeof(char)); + app = (Scheme_App_Rec *)scheme_malloc_tagged(size); + + app->so.type = scheme_application_type; + + app->num_args = n - 1; + + return app; +} + +void scheme_finish_application(Scheme_App_Rec *app) +{ + int i, devals, n; + + n = app->num_args + 1; + + devals = sizeof(Scheme_App_Rec) + (app->num_args * sizeof(Scheme_Object *)); + + for (i = 0; i < n; i++) { + char etype; + etype = scheme_get_eval_type(app->args[i]); + ((char *)app XFORM_OK_PLUS devals)[i] = etype; + } +} + +/*========================================================================*/ +/* compilation dispatcher */ +/*========================================================================*/ + +static Scheme_Object * +scheme_inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec, int start_app_position) +{ + int len; + + len = scheme_stx_proper_list_length(form); + + if (!len) { + scheme_compile_rec_done_local(rec, drec); + scheme_default_compile_rec(rec, drec); + return scheme_null; + } else if (len > 0) { + Scheme_Compile_Info *recs, quick[5]; + int i; + Scheme_Object *c, *p, *comp_first, *comp_last, *name, *first, *rest; + + name = rec[drec].value_name; + scheme_compile_rec_done_local(rec, drec); + + if (len <= 5) + recs = quick; + else + recs = MALLOC_N_RT(Scheme_Compile_Info, len); + scheme_init_compile_recs(rec, drec, recs, len); + recs[len - 1].value_name = name; + + comp_first = comp_last = NULL; + + for (i = 0, rest = form; i < len; i++) { + first = SCHEME_STX_CAR(rest); + rest = SCHEME_STX_CDR(rest); + + c = scheme_compile_expand_expr(first, env, recs, i, + !i && start_app_position); + + p = scheme_make_pair(c, scheme_null); + if (comp_last) + SCHEME_CDR(comp_last) = p; + else + comp_first = p; + comp_last = p; + } + + scheme_merge_compile_recs(rec, drec, recs, len); + + return comp_first; + } else { + scheme_signal_error("internal error: compile-list on non-list"); + return NULL; + } +} + +static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *result; + int len; + + len = scheme_stx_proper_list_length(form); + + if (len < 0) + scheme_wrong_syntax(scheme_application_stx_string, NULL, form, NULL); + + scheme_compile_rec_done_local(rec, drec); + scheme_rec_add_certs(rec, drec, form); + form = scheme_inner_compile_list(form, scheme_no_defines(env), rec, drec, 1); + + result = scheme_make_application(form); + + return result; +} + +Scheme_Object * +scheme_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return scheme_inner_compile_list(form, env, rec, drec, 0); +} + +Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, + Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + int internel_def_pos, + Scheme_Object **current_val, + Scheme_Comp_Env **_xenv, + Scheme_Object *ctx) +{ + Scheme_Object *name, *val, *certs; + Scheme_Comp_Env *xenv = (_xenv ? *_xenv : NULL); + Scheme_Expand_Info erec1; + Scheme_Env *menv = NULL; + int need_cert; + + SCHEME_EXPAND_OBSERVE_ENTER_CHECK(rec[drec].observer, first); + + while (1) { + *current_val = NULL; + + if (SCHEME_STX_PAIRP(first)) { + name = SCHEME_STX_CAR(first); + need_cert = 1; + } else { + name = first; + need_cert = 0; + } + + if (!SCHEME_STX_SYMBOLP(name)) { + SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); + return first; + } + + while (1) { + + if (need_cert) { + /* While resolving name, we need certs from `first' */ + scheme_init_expand_recs(rec, drec, &erec1, 1); + scheme_rec_add_certs(&erec1, 0, first); + certs = erec1.certs; + } else + certs = rec[drec].certs; + + val = scheme_lookup_binding(name, env, + SCHEME_NULL_FOR_UNBOUND + + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + + SCHEME_DONT_MARK_USE + + ((!rec[drec].comp && (rec[drec].depth == -2)) + ? SCHEME_OUT_OF_CONTEXT_OK + : 0) + + ((rec[drec].comp && rec[drec].resolve_module_ids) + ? SCHEME_RESOLVE_MODIDS + : 0), + certs, env->in_modidx, + &menv, NULL, NULL); + + if (SCHEME_STX_PAIRP(first)) + *current_val = val; + + if (!val) { + SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); + return first; + } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { + if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) { + /* It's a rename. Look up the target name and try again. */ + name = scheme_transfer_srcloc(scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), + scheme_false, menv, name, NULL, 1), + name); + menv = NULL; + SCHEME_USE_FUEL(1); + } else { + /* It's a normal macro; expand once. Also, extend env to indicate + an internal-define position, if necessary. */ + if (!xenv) { + if (internel_def_pos) { + xenv = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, env, NULL); + if (ctx) + xenv->intdef_name = ctx; + if (_xenv) + *_xenv = xenv; + } else + xenv = env; + } + { + scheme_init_expand_recs(rec, drec, &erec1, 1); + erec1.depth = 1; + erec1.value_name = rec[drec].value_name; + first = scheme_expand_expr(first, xenv, &erec1, 0); + } + break; /* break to outer loop */ + } + } else { + SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); + return first; + } + } + } +} + +static Scheme_Object * +compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *macro, + Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec) +{ + Scheme_Object *xformer, *boundname; + + xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro); + + if (scheme_is_set_transformer(xformer)) { + /* scheme_apply_macro unwraps it */ + } else { + if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) { + scheme_wrong_syntax(NULL, NULL, form, "illegal use of syntax"); + return NULL; + } + } + + boundname = rec[drec].value_name; + if (!boundname) + boundname = scheme_false; + + return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0); + + /* caller expects rec[drec] to be used to compile the result... */ +} + +static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e) +{ + while (1) { + if (orig == e) + return 1; + if (e && e->flags & SCHEME_FOR_STOPS) + e = e->next; + else + return 0; + } +} + +static Scheme_Object *compile_expand_expr_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; + Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; + Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + return scheme_compile_expand_expr(form, + env, + rec, + p->ku.k.i3, + p->ku.k.i2); +} + +Scheme_Object * +scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + int app_position) +{ + Scheme_Object *name, *var, *stx, *normal, *can_recycle_stx = NULL, *orig_unbound_name = NULL; + Scheme_Env *menv = NULL; + GC_CAN_IGNORE char *not_allowed; + int looking_for_top, has_orig_unbound = 0; + + top: + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + Scheme_Compile_Expand_Info *recx; + + recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info); + memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); +#ifdef MZTAG_REQUIRED + recx->type = scheme_rt_compile_info; +#endif + + p->ku.k.p1 = (void *)form; + p->ku.k.p2 = (void *)env; + p->ku.k.p3 = (void *)recx; + p->ku.k.i3 = 0; + p->ku.k.i2 = app_position; + + var = scheme_handle_stack_overflow(compile_expand_expr_k); + + memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); + return var; + } + } +#endif + + DO_CHECK_FOR_BREAK(scheme_current_thread, ;); + +#if 1 + if (!SCHEME_STXP(form)) + scheme_signal_error("not syntax"); +#endif + + if (rec[drec].comp) { + scheme_default_compile_rec(rec, drec); + } else { + SCHEME_EXPAND_OBSERVE_VISIT(rec[drec].observer,form); + } + + if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) { + var = SCHEME_STX_VAL(form); + if (scheme_stx_has_empty_wraps(form) + && same_effective_env(SCHEME_PTR2_VAL(var), env)) { + /* FIXME: this needs EXPAND_OBSERVE callbacks. */ + var = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form); + form = scheme_stx_cert(var, scheme_false, NULL, form, NULL, 1); + if (!rec[drec].comp && (rec[drec].depth != -1)) { + /* Already fully expanded. */ + return form; + } + } else { + scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), + "expanded syntax not in its original lexical context" + " (extra bindings or marks in the current context)"); + } + } + + looking_for_top = 0; + + if (SCHEME_STX_NULLP(form)) { + stx = app_symbol; + not_allowed = "function application"; + normal = app_expander; + } else if (!SCHEME_STX_PAIRP(form)) { + if (SCHEME_STX_SYMBOLP(form)) { + Scheme_Object *find_name = form, *lexical_binding_id; + int protected = 0; + + while (1) { + lexical_binding_id = NULL; + var = scheme_lookup_binding(find_name, env, + SCHEME_NULL_FOR_UNBOUND + + SCHEME_ENV_CONSTANTS_OK + + (rec[drec].comp + ? SCHEME_ELIM_CONST + : 0) + + (app_position + ? SCHEME_APP_POS + : 0) + + ((rec[drec].comp && rec[drec].dont_mark_local_use) ? + SCHEME_DONT_MARK_USE + : 0) + + ((rec[drec].comp && rec[drec].resolve_module_ids) + ? SCHEME_RESOLVE_MODIDS + : 0) + + ((!rec[drec].comp && (rec[drec].depth == -2)) + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) + : 0), + rec[drec].certs, env->in_modidx, + &menv, &protected, &lexical_binding_id); + + SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name); + + if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { + /* It's a rename. Look up the target name and try again. */ + Scheme_Object *new_name; + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + if (!rec[drec].comp) { + new_name = scheme_stx_track(new_name, find_name, find_name); + } + new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); + find_name = scheme_transfer_srcloc(new_name, find_name); + SCHEME_USE_FUEL(1); + menv = NULL; + protected = 0; + } else + break; + } + + if (!var) { + /* Top variable */ + stx = top_symbol; + if (env->genv->module) + not_allowed = "reference to an unbound identifier"; + else + not_allowed = "reference to a top-level identifier"; + normal = top_expander; + has_orig_unbound = 1; + form = find_name; /* in case it was re-mapped */ + looking_for_top = 1; + } else { + if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { + if (var == stop_expander) { + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer,form); + SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer); + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer,form); + SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer,form); + return form; + } else { + scheme_wrong_syntax(NULL, NULL, form, "bad syntax"); + return NULL; + } + } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { + name = form; + goto macro; + } + + if (rec[drec].comp) { + scheme_compile_rec_done_local(rec, drec); + if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) + && scheme_extract_unsafe(var)) { + scheme_register_unsafe_in_prefix(env, rec, drec, menv); + return scheme_extract_unsafe(var); + } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) + && scheme_extract_flfxnum(var)) { + return scheme_extract_flfxnum(var); + } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) + && scheme_extract_futures(var)) { + return scheme_extract_futures(var); + } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) + return scheme_register_toplevel_in_prefix(var, env, rec, drec, + scheme_is_imported(var, env)); + else + return var; + } else { + SCHEME_EXPAND_OBSERVE_VARIABLE(rec[drec].observer, form, find_name); + if (lexical_binding_id) { + find_name = lexical_binding_id; + } + if (protected) { + /* Add a property to indicate that the name is protected */ + find_name = scheme_stx_property(find_name, protected_symbol, scheme_true); + } + SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, find_name); + return find_name; /* which is usually == form */ + } + } + } else { + /* A hack for handling lifted expressions. See compile_expand_lift_to_let. */ + if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_already_comp_type)) { + form = SCHEME_STX_VAL(form); + return SCHEME_IPTR_VAL(form); + } + + stx = datum_symbol; + not_allowed = "literal data"; + normal = datum_expander; + } + } else { + name = SCHEME_STX_CAR(form); + if (SCHEME_STX_SYMBOLP(name)) { + /* Check for macros: */ + Scheme_Object *find_name = name; + Scheme_Expand_Info erec1; + + /* While resolving name, we need certs from `form' */ + scheme_init_expand_recs(rec, drec, &erec1, 1); + scheme_rec_add_certs(&erec1, 0, form); + + while (1) { + var = scheme_lookup_binding(find_name, env, + SCHEME_APP_POS + + SCHEME_NULL_FOR_UNBOUND + + SCHEME_ENV_CONSTANTS_OK + + (rec[drec].comp + ? SCHEME_ELIM_CONST + : 0) + + SCHEME_DONT_MARK_USE + + ((rec[drec].comp && rec[drec].resolve_module_ids) + ? SCHEME_RESOLVE_MODIDS + : 0) + + ((!rec[drec].comp && (rec[drec].depth == -2)) + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) + : 0), + erec1.certs, env->in_modidx, + &menv, NULL, NULL); + + SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); + if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { + /* It's a rename. Look up the target name and try again. */ + Scheme_Object *new_name; + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + if (!rec[drec].comp) { + new_name = scheme_stx_track(new_name, find_name, find_name); + } + new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); + find_name = scheme_transfer_srcloc(new_name, find_name); + SCHEME_USE_FUEL(1); + menv = NULL; + } else + break; + } + + if (!var) { + /* apply to global variable: compile it normally */ + orig_unbound_name = find_name; + has_orig_unbound = 1; + } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) { + /* apply to local variable: compile it normally */ + } else { + if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { + goto macro; + } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { + if (rec[drec].comp) { + Scheme_Syntax *f; + f = (Scheme_Syntax *)SCHEME_SYNTAX(var); + return f(form, env, rec, drec); + } else { + Scheme_Syntax_Expander *f; + f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form); + form = f(form, env, rec, drec); + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form); + SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); + return form; + } + } + + /* Else: unknown global - must be a function: compile as application */ + } + + if (!SAME_OBJ(name, find_name)) { + /* the rator position was mapped */ + Scheme_Object *code; + code = SCHEME_STX_CDR(form); + code = scheme_make_pair(find_name, code); + form = scheme_datum_to_syntax(code, form, form, 0, 0); + } + } + + stx = app_symbol; + not_allowed = "function application"; + normal = app_expander; + } + + /* Compile/expand as application, datum, or top: */ + if (quick_stx && rec[drec].comp) { + ((Scheme_Stx *)quick_stx)->val = stx; + ((Scheme_Stx *)quick_stx)->wraps = ((Scheme_Stx *)form)->wraps; + ((Scheme_Stx *)quick_stx)->u.modinfo_cache = NULL; + stx = quick_stx; + quick_stx = NULL; + } else + stx = scheme_datum_to_syntax(stx, scheme_false, form, 0, 0); + if (rec[drec].comp) + can_recycle_stx = stx; + + { + Scheme_Object *find_name = stx; + + while (1) { + var = scheme_lookup_binding(find_name, env, + SCHEME_NULL_FOR_UNBOUND + + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + + SCHEME_DONT_MARK_USE + + ((!rec[drec].comp && (rec[drec].depth == -2)) + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) + : 0), + rec[drec].certs, env->in_modidx, + &menv, NULL, NULL); + + SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); + + if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { + /* It's a rename. Look up the target name and try again. */ + Scheme_Object *new_name; + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); + if (!rec[drec].comp) { + new_name = scheme_stx_track(new_name, find_name, find_name); + } + new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); + find_name = scheme_transfer_srcloc(new_name, find_name); + SCHEME_USE_FUEL(1); + menv = NULL; + } else + break; + } + } + + if (!SAME_OBJ(var, normal)) { + /* Someone might keep the stx: */ + can_recycle_stx = NULL; + } + + if (!var && looking_for_top) { + /* If form is a marked name, then force #%top binding. + This is so temporaries can be used as defined ids. */ + Scheme_Object *nm; + nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL, NULL); + if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) { + stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); + + /* Should be either top_expander or stop_expander: */ + var = scheme_lookup_binding(stx, env, + SCHEME_NULL_FOR_UNBOUND + + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + + SCHEME_DONT_MARK_USE + + ((!rec[drec].comp && (rec[drec].depth == -2)) + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) + : 0), + rec[drec].certs, env->in_modidx, + &menv, NULL, NULL); + } + } + + if (var && (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) + || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type))) { + if (SAME_OBJ(var, stop_expander)) { + /* Return original: */ + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form); + SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer); + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form); + SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); + return form; + } else if (rec[drec].comp && SAME_OBJ(var, normal) && !rec[drec].observer) { + /* Skip creation of intermediate form */ + Scheme_Syntax *f; + rec[drec].pre_unwrapped = 1; + f = (Scheme_Syntax *)SCHEME_SYNTAX(var); + if (can_recycle_stx && !quick_stx) + quick_stx = can_recycle_stx; + return f(form, env, rec, drec); + } else { + form = scheme_datum_to_syntax(scheme_make_pair(stx, form), form, form, 0, 2); + SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, form); + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { + if (rec[drec].comp) { + Scheme_Syntax *f; + f = (Scheme_Syntax *)SCHEME_SYNTAX(var); + return f(form, env, rec, drec); + } else { + Scheme_Syntax_Expander *f; + f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); + SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form); + form = f(form, env, rec, drec); + SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form); + SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); + return form; + } + } else { + name = stx; + goto macro; + } + } + } else { + /* Not allowed this context! */ + char *phase, buf[30]; + if (env->genv->phase == 0) + phase = ""; + else if (env->genv->phase == 1) + phase = " in the transformer environment"; + else { + phase = buf; + sprintf(buf, " at phase %" PRIdPTR, env->genv->phase); + } + if (has_orig_unbound) { + scheme_wrong_syntax(scheme_compile_stx_string, + orig_unbound_name, form, + "unbound identifier%s " + "(and no %S syntax transformer is bound)", + phase, + SCHEME_STX_VAL(stx)); + } else { + scheme_wrong_syntax(scheme_compile_stx_string, NULL, form, + "bad syntax; %s is not allowed, " + "because no %S syntax transformer is bound%s", + not_allowed, + SCHEME_STX_VAL(stx), + phase); + } + return NULL; + } + + macro: + if (!rec[drec].comp && !rec[drec].depth) { + SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); + return form; /* We've gone as deep as requested */ + } + + SCHEME_EXPAND_OBSERVE_ENTER_MACRO(rec[drec].observer, form); + form = compile_expand_macro_app(name, menv, var, form, env, rec, drec); + SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form); + + if (rec[drec].comp) + goto top; + else { + if (rec[drec].depth > 0) + --rec[drec].depth; + if (rec[drec].depth) + goto top; + else { + SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); + return form; + } + } +} + +static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env) +{ + Scheme_Object *l, *id, *form = lam; + int cnt = 0; + DupCheckRecord r; + + lam = SCHEME_STX_CDR(lam); + if (!SCHEME_STX_PAIRP(lam)) return -1; + + l = SCHEME_STX_CAR(lam); + + lam = SCHEME_STX_CDR(lam); + if (!SCHEME_STX_PAIRP(lam)) return -1; + + while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); } + if (!SCHEME_STX_NULLP(lam)) return -1; + + + scheme_begin_dup_symbol_check(&r, env); + + while (SCHEME_STX_PAIRP(l)) { + id = SCHEME_STX_CAR(l); + scheme_check_identifier("lambda", id, NULL, env, form); + scheme_dup_symbol_check(&r, NULL, id, "argument", form); + l = SCHEME_STX_CDR(l); + cnt++; + } + if (!SCHEME_STX_NULLP(l)) return -1; + + return cnt; +} + +static Scheme_Object *cert_ids(Scheme_Object *orig_ids, Scheme_Object *orig) +{ + Scheme_Object *id, *ids = orig_ids, *pr, *first = scheme_null, *last = NULL; + + while (!SCHEME_STX_NULLP(ids)) { + + id = SCHEME_STX_CAR(ids); + id = scheme_stx_cert(id, NULL, NULL, orig, NULL, 1); + + pr = scheme_make_pair(id, scheme_null); + + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + + ids = SCHEME_STX_CDR(ids); + } + + return scheme_datum_to_syntax(first, orig_ids, orig_ids, 0, 2); +} + +static Scheme_Object * +compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec) +{ + Scheme_Object *form, *naya; + int tsc; + + tsc = rec[drec].pre_unwrapped; + rec[drec].pre_unwrapped = 0; + + scheme_rec_add_certs(rec, drec, forms); + if (tsc) { + form = forms; + } else { + form = SCHEME_STX_CDR(forms); + form = scheme_datum_to_syntax(form, forms, forms, 0, 0); + } + + if (SCHEME_STX_NULLP(form)) { + /* Compile/expand empty application to null list: */ + if (rec[drec].comp) + return scheme_null; + else + return scheme_datum_to_syntax(icons(quote_symbol, + icons(form, scheme_null)), + form, + scheme_sys_wraps(env), + 0, 2); + } else if (!SCHEME_STX_PAIRP(form)) { + /* will end in error */ + if (rec[drec].comp) + return compile_application(form, env, rec, drec); + else { + rec[drec].value_name = scheme_false; + naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec); + /* naya will be prefixed and returned... */ + } + } else if (rec[drec].comp) { + Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form; + name = SCHEME_STX_CAR(form); + origname = name; + + name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL); + + /* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */ + if (SAME_OBJ(gval, scheme_lambda_syntax)) { + Scheme_Object *argsnbody; + + argsnbody = SCHEME_STX_CDR(name); + if (SCHEME_STX_PAIRP(argsnbody)) { + Scheme_Object *args, *body; + + args = SCHEME_STX_CAR(argsnbody); + body = SCHEME_STX_CDR(argsnbody); + + if (SCHEME_STX_PAIRP(body)) { + int pl; + pl = scheme_stx_proper_list_length(args); + if ((pl >= 0) || SCHEME_STX_SYMBOLP(args)) { + Scheme_Object *bindings = scheme_null, *last = NULL; + Scheme_Object *rest; + int al; + + rest = SCHEME_STX_CDR(form); + al = scheme_stx_proper_list_length(rest); + + if ((pl < 0) || (al == pl)) { + DupCheckRecord r; + + scheme_begin_dup_symbol_check(&r, env); + + while (!SCHEME_STX_NULLP(args)) { + Scheme_Object *v, *n; + + if (pl < 0) + n = args; + else + n = SCHEME_STX_CAR(args); + scheme_check_identifier("lambda", n, NULL, env, name); + + /* If we don't check here, the error is in terms of `let': */ + scheme_dup_symbol_check(&r, NULL, n, "argument", name); + + /* Propagate certifications to bound id: */ + n = scheme_stx_cert(n, NULL, NULL, name, NULL, 1); + + if (pl < 0) { + v = scheme_intern_symbol("list"); + v = scheme_datum_to_syntax(v, scheme_false, scheme_sys_wraps(env), 0, 0); + v = cons(v, rest); + } else + v = SCHEME_STX_CAR(rest); + v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null); + if (last) + SCHEME_CDR(last) = v; + else + bindings = v; + + last = v; + if (pl < 0) { + /* rator is (lambda rest-x ....) */ + break; + } else { + args = SCHEME_STX_CDR(args); + rest = SCHEME_STX_CDR(rest); + } + } + + body = scheme_datum_to_syntax(icons(begin_symbol, body), form, + scheme_sys_wraps(env), + 0, 2); + /* Copy certifications from lambda to `body'. */ + body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1); + + body = scheme_datum_to_syntax(cons(let_values_symbol, + cons(bindings, + cons(body, scheme_null))), + form, + scheme_sys_wraps(env), + 0, 2); + + return scheme_compile_expand_expr(body, env, rec, drec, 0); + } else { +#if 0 + scheme_wrong_syntax(scheme_application_stx_string, NULL, form, + "procedure application: bad ((lambda (...) ...) ...) syntax"); + return NULL; +#endif + } + } + } + } + } + + orig_rest_form = SCHEME_STX_CDR(form); + + /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ + if (SCHEME_STX_SYMBOLP(name)) { + Scheme_Object *at_first, *at_second, *the_end, *cwv_stx; + at_first = SCHEME_STX_CDR(form); + if (SCHEME_STX_PAIRP(at_first)) { + at_second = SCHEME_STX_CDR(at_first); + if (SCHEME_STX_PAIRP(at_second)) { + the_end = SCHEME_STX_CDR(at_second); + if (SCHEME_STX_NULLP(the_end)) { + Scheme_Object *orig_at_second = at_second; + + cwv_stx = scheme_datum_to_syntax(scheme_intern_symbol("call-with-values"), + scheme_false, scheme_sys_wraps(env), 0, 0); + if (scheme_stx_module_eq(name, cwv_stx, 0)) { + Scheme_Object *first, *orig_first; + orig_first = SCHEME_STX_CAR(at_first); + first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL); + if (SAME_OBJ(gval, scheme_lambda_syntax) + && SCHEME_STX_PAIRP(first) + && (arg_count(first, env) == 0)) { + Scheme_Object *second, *orig_second; + orig_second = SCHEME_STX_CAR(at_second); + second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL); + if (SAME_OBJ(gval, scheme_lambda_syntax) + && SCHEME_STX_PAIRP(second) + && (arg_count(second, env) >= 0)) { + Scheme_Object *lhs, *orig_post_first, *orig_post_second; + orig_post_first = first; + orig_post_second = second; + second = SCHEME_STX_CDR(second); + lhs = SCHEME_STX_CAR(second); + second = SCHEME_STX_CDR(second); + first = SCHEME_STX_CDR(first); + first = SCHEME_STX_CDR(first); + first = icons(begin_symbol, first); + first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1); + second = icons(begin_symbol, second); + second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1); + /* Copy certifications from lambda to body: */ + lhs = cert_ids(lhs, orig_post_second); + first = scheme_stx_cert(first, NULL, NULL, orig_post_first, NULL, 1); + second = scheme_stx_cert(second, NULL, NULL, orig_post_second, NULL, 1); + /* Convert to let-values: */ + name = icons(let_values_symbol, + icons(icons(icons(lhs, icons(first, scheme_null)), + scheme_null), + icons(second, scheme_null))); + form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2); + return scheme_compile_expand_expr(form, env, rec, drec, 0); + } + if (!SAME_OBJ(second, orig_second)) { + at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2); + } + } + if (!SAME_OBJ(first, orig_first) + || !SAME_OBJ(at_second, orig_at_second)) { + at_first = scheme_datum_to_syntax(icons(first, at_second), at_first, at_first, 0, 2); + } + } + } + } + } + rest_form = at_first; + } else { + rest_form = orig_rest_form; + } + + if (NOT_SAME_OBJ(name, origname) + || NOT_SAME_OBJ(rest_form, orig_rest_form)) { + form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, forms, 0, 2); + } + + return compile_application(form, env, rec, drec); + } else { + scheme_rec_add_certs(rec, drec, form); + rec[drec].value_name = scheme_false; + naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec); + /* naya will be prefixed returned... */ + } + + if (SAME_OBJ(form, naya)) + return forms; + + /* Add #%app prefix back: */ + { + Scheme_Object *first; + + first = SCHEME_STX_CAR(forms); + return scheme_datum_to_syntax(scheme_make_pair(first, naya), + forms, + forms, 0, 2); + } +} + +static Scheme_Object * +app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + return compile_expand_app(form, env, rec, drec); +} + +static Scheme_Object * +app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_APP(erec[drec].observer); + return compile_expand_app(form, env, erec, drec); +} + +static Scheme_Object * +datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *c, *v; + + if (rec[drec].pre_unwrapped) { + c = form; + rec[drec].pre_unwrapped = 0; + } else { + c = SCHEME_STX_CDR(form); + /* Need datum->syntax, in case c is a list: */ + c = scheme_datum_to_syntax(c, form, form, 0, 2); + } + + v = SCHEME_STX_VAL(c); + if (SCHEME_KEYWORDP(v)) { + scheme_wrong_syntax("#%datum", NULL, c, "keyword used as an expression"); + return NULL; + } + + return scheme_syntax_to_datum(c, 0, NULL); +} + +static Scheme_Object * +datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *rest, *v; + + SCHEME_EXPAND_OBSERVE_PRIM_DATUM(erec[drec].observer); + + rest = SCHEME_STX_CDR(form); + + v = SCHEME_STX_VAL(rest); + if (SCHEME_KEYWORDP(v)) { + scheme_wrong_syntax("#%datum", NULL, rest, "keyword used as an expression"); + return NULL; + } + + return scheme_datum_to_syntax(icons(quote_symbol, + icons(rest, scheme_null)), + form, + scheme_sys_wraps(env), + 0, 2); +} + +static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *c; + + if (rec[drec].pre_unwrapped) { + c = form; + rec[drec].pre_unwrapped = 0; + } else + c = SCHEME_STX_CDR(form); + + if (!SCHEME_STX_SYMBOLP(c)) + scheme_wrong_syntax(NULL, NULL, form, NULL); + + if (env->genv->module) { + Scheme_Object *modidx, *symbol = c, *tl_id; + int bad; + + tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL); + if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { + /* Since the module has a rename for this id, it's certainly defined. */ + } else { + modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL, NULL); + if (modidx) { + /* If it's an access path, resolve it: */ + if (env->genv->module + && SAME_OBJ(scheme_module_resolve(modidx, 1), env->genv->module->modname)) + bad = 0; + else + bad = 1; + } else + bad = 1; + + if (env->genv->disallow_unbound) { + if (bad || !scheme_lookup_in_table(env->genv->toplevel, (const char *)SCHEME_STX_SYM(c))) { + GC_CAN_IGNORE const char *reason; + if (env->genv->phase == 1) { + reason = "unbound identifier in module (in phase 1, transformer environment)"; + /* Check in the run-time environment */ + if (scheme_lookup_in_table(env->genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) { + reason = ("unbound identifier in module (in the transformer environment, which does" + " not include the run-time definition)"); + } else if (env->genv->template_env->syntax + && scheme_lookup_in_table(env->genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) { + reason = ("unbound identifier in module (in the transformer environment, which does" + " not include the macro definition that is visible to run-time expressions)"); + } + } else if (env->genv->phase == 0) + reason = "unbound identifier in module"; + else + reason = "unbound identifier in module (in phase %d)"; + scheme_wrong_syntax(when, NULL, c, reason, env->genv->phase); + } + } + } + } + + return c; +} + +static Scheme_Object * +top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +{ + Scheme_Object *c; + + c = check_top(scheme_compile_stx_string, form, env, rec, drec); + + c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL); + + if (env->genv->module && !rec[drec].resolve_module_ids) { + /* Self-reference in a module; need to remember the modidx. Don't + need a pos, because the symbol's gensym-ness (if any) will be + preserved within the module. */ + c = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, + c, env->genv->module->insp, + -1, env->genv->mod_phase); + } else { + c = (Scheme_Object *)scheme_global_bucket(c, env->genv); + } + + return scheme_register_toplevel_in_prefix(c, env, rec, drec, 0); +} + +static Scheme_Object * +top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_TOP(erec[drec].observer); + check_top(scheme_expand_stx_string, form, env, erec, drec); + return form; +} + +Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return scheme_compile_expand_expr(form, env, rec, drec, 0); +} + +Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Expand_Info *erec, int drec) +{ + return scheme_compile_expand_expr(form, env, erec, drec, 0); +} + +Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) +{ + Scheme_Comp_Env **ip = (Scheme_Comp_Env **)_ip, *naya; + Scheme_Object *ids, *id; + int pos; + + pos = scheme_list_length(*_ids); + naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, (*ip)->next, NULL); + (*ip)->next = naya; + *ip = naya; + + for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { + id = SCHEME_CAR(ids); + scheme_add_compilation_binding(--pos, id, naya); + } + + return icons(*_ids, icons(expr, scheme_null)); +} + +Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, + Scheme_Object *orig_form, int comp_rev) +{ + Scheme_Object *revl, *a; + + if (SCHEME_NULLP(l)) return obj; + + revl = scheme_reverse(l); + + if (comp_rev) { + /* We've already compiled the body of this let + with the bindings in reverse order. So insert a series of `lets' + to match that order: */ + if (!SCHEME_NULLP(SCHEME_CDR(l))) { + for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + a = scheme_reverse(SCHEME_CAR(SCHEME_CAR(l))); + for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) { + obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), + icons(icons(icons(icons(SCHEME_CAR(a), scheme_null), icons(SCHEME_CAR(a), scheme_null)), + scheme_null), + icons(obj, scheme_null))); + } + } + } + } + + for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) { + a = SCHEME_CAR(revl); + obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), + icons(icons(a, scheme_null), + icons(obj, scheme_null))); + } + + obj = scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0); + + return obj; +} + +static Scheme_Object *compile_expand_expr_lift_to_let_k(void); + +static Scheme_Object * +compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Expand_Info *rec, int drec) +{ + Scheme_Expand_Info recs[2]; + Scheme_Object *l, *orig_form = form, *context_key; + Scheme_Comp_Env *inserted, **ip; + + /* This function only works when `env' has no lexical bindings, + because we might insert new ones at the beginning. In + particular, we might insert frames between `inserted' and + `env'. + + This function also relies on the way that compilation of `let' + works. A let-bound variable is compiled to a count of the frames + to skip and the index within the frame, so we can insert new + frames without affecting lookups computed so far. Inserting each + new frame before any previous one turns out to be consistent with + the nested `let's that we generate at the end. + + Some optimizations can happen later, for example constant + propagate. But these optimizations take place on the result of + this function, so we don't have to worry about them. + + Don't generate a `let*' expression instead of nested `let's, + because the compiler actually takes shortcuts (that are + inconsistent with our frame nesting) instead of expanding `let*' + to `let'. */ + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + Scheme_Compile_Expand_Info *recx; + + recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info); + memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); +#ifdef MZTAG_REQUIRED + recx->type = scheme_rt_compile_info; +#endif + + p->ku.k.p1 = (void *)form; + p->ku.k.p2 = (void *)env; + p->ku.k.p3 = (void *)recx; + + form = scheme_handle_stack_overflow(compile_expand_expr_lift_to_let_k); + + memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); + return form; + } + } +#endif + + inserted = scheme_new_compilation_frame(0, 0, env, NULL); + + ip = MALLOC_N(Scheme_Comp_Env *, 1); + *ip = inserted; + + context_key = scheme_generate_lifts_key(); + + scheme_frame_captures_lifts(inserted, scheme_pair_lifted, (Scheme_Object *)ip, scheme_false, + context_key, NULL, scheme_false); + + if (rec[drec].comp) { + scheme_init_compile_recs(rec, drec, recs, 2); + form = scheme_compile_expr(form, inserted, recs, 0); + } else { + scheme_init_expand_recs(rec, drec, recs, 2); + form = scheme_expand_expr(form, inserted, recs, 0); + } + + l = scheme_frame_get_lifts(inserted); + if (SCHEME_NULLP(l)) { + /* No lifts */ + if (rec[drec].comp) + scheme_merge_compile_recs(rec, drec, recs, 1); + return form; + } else { + /* We have lifts, so add let* wrapper and go again */ + Scheme_Object *o; + if (rec[drec].comp) { + /* Wrap compiled part so the compiler recognizes it later: */ + o = scheme_alloc_object(); + o->type = scheme_already_comp_type; + SCHEME_IPTR_VAL(o) = form; + } else + o = form; + form = scheme_add_lifts_as_let(o, l, env, orig_form, rec[drec].comp); + SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(rec[drec].observer, form); + form = compile_expand_expr_lift_to_let(form, env, recs, 1); + if (rec[drec].comp) + scheme_merge_compile_recs(rec, drec, recs, 2); + return form; + } +} + +static Scheme_Object *compile_expand_expr_lift_to_let_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; + Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; + Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + return compile_expand_expr_lift_to_let(form, env, rec, 0); +} + +Scheme_Object * +scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return compile_expand_expr_lift_to_let(form, env, rec, drec); +} + +Scheme_Object * +scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Expand_Info *erec, int drec) +{ + return compile_expand_expr_lift_to_let(form, env, erec, drec); +} + +static Scheme_Object * +scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + int mixed) +/* This ugly code parses a block of code, transforming embedded + define-values and define-syntax into letrec and letrec-syntax. + It is espcailly ugly because we have to expand macros + before deciding what we have. */ +{ + Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms, *pre_exprs = scheme_null; + void **d; + Scheme_Comp_Env *xenv = NULL; + Scheme_Compile_Info recs[2]; + DupCheckRecord r; + + if (rec[drec].comp) { + scheme_default_compile_rec(rec, drec); + } else { + SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(rec[drec].observer, forms); + } + + if (SCHEME_STX_NULLP(forms)) { + if (rec[drec].comp) { + scheme_compile_rec_done_local(rec, drec); + return scheme_null; + } else { + SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms); + SCHEME_EXPAND_OBSERVE_ENTER_LIST(rec[drec].observer, forms); + SCHEME_EXPAND_OBSERVE_EXIT_LIST(rec[drec].observer, forms); + return forms; + } + } + + rib = scheme_make_rename_rib(); + ctx = scheme_alloc_object(); + ctx->type = scheme_intdef_context_type; + d = MALLOC_N(void*, 3); + d[0] = env; + SCHEME_PTR1_VAL(ctx) = d; + SCHEME_PTR2_VAL(ctx) = rib; + ectx = scheme_make_pair(ctx, scheme_null); + scheme_begin_dup_symbol_check(&r, env); + + try_again: + + SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); + + if (!SCHEME_STX_PAIRP(forms)) { + scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax"); + return NULL; + } + + first = SCHEME_STX_CAR(forms); + + { + /* Need to send both parts (before & after) of block rename */ + Scheme_Object *old_first; + + old_first = first; + first = scheme_add_rename_rib(first, rib); + + SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first); + } + + { + Scheme_Object *gval, *result; + int more = 1; + + result = forms; + + /* Check for macro expansion, which could mask the real + define-values, define-syntax, etc.: */ + first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx); + + if (SAME_OBJ(gval, scheme_begin_syntax)) { + /* Inline content */ + Scheme_Object *orig_forms = forms; + + SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer); + + /* FIXME: Redundant with check done by scheme_flatten_begin below? */ + if (scheme_stx_proper_list_length(first) < 0) + scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, + "bad syntax (" IMPROPER_LIST_FORM ")"); + + forms = SCHEME_STX_CDR(forms); + + if (SCHEME_STX_NULLP(forms)) { + /* A `begin' that ends the block. An `inferred-name' property + attached to this begin should apply to the ultimate last + thing in the block. */ + Scheme_Object *v; + v = scheme_check_name_property(first, rec[drec].value_name); + rec[drec].value_name = v; + } + + forms = scheme_flatten_begin(first, forms); + + SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer, forms); + + if (SCHEME_STX_NULLP(forms)) { + if (!SCHEME_PAIRP(pre_exprs)) { + scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, + "bad syntax (empty form)"); + return NULL; + } else { + /* fall through to handle expressions without definitions */ + } + } else { + forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); + + goto try_again; + } + + forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); + } else if (SAME_OBJ(gval, scheme_define_values_syntax) + || SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { + /* Turn defines into a letrec: */ + Scheme_Object *var, *vars, *v, *link; + Scheme_Object *l = scheme_null, *start = NULL; + Scheme_Object *stx_l = scheme_null, *stx_start = NULL; + int is_val; + + while (1) { + int cnt; + + if (!SCHEME_NULLP(pre_exprs)) { + Scheme_Object *begin_stx, *values_app_stx; + + pre_exprs = scheme_reverse(pre_exprs); + + begin_stx = scheme_datum_to_syntax(begin_symbol, + scheme_false, + scheme_sys_wraps(env), + 0, 0); + values_app_stx = scheme_datum_to_syntax(scheme_make_pair(values_symbol, scheme_null), + scheme_false, + scheme_sys_wraps(env), + 0, 0); + + while (SCHEME_PAIRP(pre_exprs)) { + v = scheme_make_pair(scheme_null, + scheme_make_pair(scheme_make_pair(begin_stx, + scheme_make_pair(SCHEME_CAR(pre_exprs), + scheme_make_pair(values_app_stx, + scheme_null))), + scheme_null)); + v = scheme_datum_to_syntax(v, SCHEME_CAR(pre_exprs), SCHEME_CAR(pre_exprs), 0, 0); + + link = scheme_make_pair(v, scheme_null); + if (!start) + start = link; + else + SCHEME_CDR(l) = link; + l = link; + + pre_exprs = SCHEME_CDR(pre_exprs); + } + } + + is_val = SAME_OBJ(gval, scheme_define_values_syntax); + + v = SCHEME_STX_CDR(first); + + if (is_val) { + SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(rec[drec].observer); + } else { + SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(rec[drec].observer); + } + + if (!SCHEME_STX_PAIRP(v)) + scheme_wrong_syntax(NULL, NULL, first, + "bad syntax (" IMPROPER_LIST_FORM ")"); + + var = NULL; + vars = SCHEME_STX_CAR(v); + cnt = 0; + while (SCHEME_STX_PAIRP(vars)) { + var = SCHEME_STX_CAR(vars); + if (!SCHEME_STX_SYMBOLP(var)) + scheme_wrong_syntax(NULL, var, first, + "name must be an identifier"); + /* scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); */ + vars = SCHEME_STX_CDR(vars); + cnt++; + } + if (!SCHEME_STX_NULLP(vars)) { + vars = SCHEME_STX_CAR(v); + scheme_wrong_syntax(NULL, vars, first, + "not a sequence of identifiers"); + } + + /* Preserve properties and track at the clause level: */ + v = scheme_datum_to_syntax(v, first, first, 0, 0); + var = SCHEME_STX_CAR(first); + v = scheme_stx_track(v, first, var); + + SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer,v); + + link = scheme_make_pair(v, scheme_null); + if (is_val) { + if (!start) + start = link; + else + SCHEME_CDR(l) = link; + l = link; + } else { + if (!stx_start) + stx_start = link; + else + SCHEME_CDR(stx_l) = link; + stx_l = link; + } + + result = SCHEME_STX_CDR(result); + if (!SCHEME_STX_NULLP(result) && !SCHEME_STX_PAIRP(result)) + scheme_wrong_syntax(NULL, NULL, first, NULL); + + { + /* Execute internal macro definition and register non-macros */ + Scheme_Comp_Env *new_env; + Scheme_Object *names, *expr, *l, *a; + int pos; + + new_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, env, rec[drec].certs); + + names = SCHEME_STX_CAR(v); + expr = SCHEME_STX_CDR(v); + if (!SCHEME_STX_PAIRP(expr)) { + if (SCHEME_STX_NULLP(expr)) + scheme_wrong_syntax(NULL, NULL, first, + "bad syntax (missing expression)"); + else + scheme_wrong_syntax(NULL, NULL, first, + "bad syntax (" IMPROPER_LIST_FORM ")"); + } + link = SCHEME_STX_CDR(expr); + if (!SCHEME_STX_NULLP(link)) { + scheme_wrong_syntax(NULL, NULL, first, + "bad syntax (extra data after expression)"); + } + expr = SCHEME_STX_CAR(expr); + + scheme_add_local_syntax(cnt, new_env); + + /* Initialize environment slots to #f, which means "not syntax". */ + cnt = 0; + for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + scheme_set_local_syntax(cnt++, a, scheme_false, new_env); + } + + /* Extend shared rib with renamings */ + scheme_add_env_renames(rib, new_env, env); + + /* Check for duplicates after extending the rib with renamings, + since the renamings properly track marks. */ + for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + scheme_dup_symbol_check(&r, "internal definition", a, "binding", first); + } + + if (!is_val) { + /* Evaluate and bind syntaxes */ + scheme_prepare_exp_env(new_env->genv); + scheme_prepare_compile_env(new_env->genv->exp_env); + pos = 0; + expr = scheme_add_rename_rib(expr, rib); + scheme_bind_syntaxes("local syntax definition", + names, expr, + new_env->genv->exp_env, new_env->insp, rec, drec, + new_env, new_env, + &pos, rib); + } + + /* Remember extended environment */ + ((void **)SCHEME_PTR1_VAL(ctx))[0] = new_env; + env = new_env; + xenv = NULL; + } + + define_try_again: + if (!SCHEME_STX_NULLP(result)) { + first = SCHEME_STX_CAR(result); + first = scheme_datum_to_syntax(first, forms, forms, 0, 0); + { + Scheme_Object *old_first; + old_first = first; + first = scheme_add_rename_rib(first, rib); + SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); + SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first); + } + first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx); + more = 1; + if (NOT_SAME_OBJ(gval, scheme_define_values_syntax) + && NOT_SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { + if (SAME_OBJ(gval, scheme_begin_syntax)) { + /* Inline content */ + result = SCHEME_STX_CDR(result); + SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer); + result = scheme_flatten_begin(first, result); + SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer,result); + goto define_try_again; + } else if (mixed) { + /* accumulate expr for either sequence after definitions + or made-up empty bindings before the next definition */ + pre_exprs = scheme_make_pair(first, pre_exprs); + result = SCHEME_STX_CDR(result); + goto define_try_again; + } else { + /* Keep partially expanded `first': */ + result = SCHEME_STX_CDR(result); + result = scheme_make_pair(first, result); + break; + } + } + } else + break; + } + + if (SCHEME_STX_PAIRP(result) || SCHEME_PAIRP(pre_exprs)) { + if (!start) + start = scheme_null; + + if (SCHEME_PAIRP(pre_exprs)) + result = scheme_reverse(pre_exprs); /* from mixed mode */ + + if (!mixed) { + result = scheme_make_pair(scheme_make_pair(scheme_intern_symbol("#%stratified-body"), + result), + scheme_null); + } + + if (stx_start) { + result = scheme_make_pair(letrec_syntaxes_symbol, + scheme_make_pair(stx_start, + scheme_make_pair(start, result))); + } else { + result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result)); + } + result = scheme_datum_to_syntax(result, forms, scheme_sys_wraps(env), 0, 2); + result = scheme_add_rename_rib(result, rib); + + more = 0; + } else { + /* Empty body: illegal. */ + scheme_wrong_syntax(scheme_begin_stx_string, NULL, orig, + "no expression after a sequence of internal definitions"); + } + } else if (mixed) { + /* accumulate expr for either an expr-only sequence or made-up + empty bindings before a definition that appears later */ + pre_exprs = scheme_make_pair(first, pre_exprs); + first = SCHEME_STX_CDR(forms); + forms = scheme_datum_to_syntax(first, forms, forms, 0, 0); + if (SCHEME_STX_NULLP(forms)) { + /* fall through to handle expressions without definitions */ + } else { + goto try_again; + } + } else { + /* fall through to handle just expressions in non-mixed mode */ + } + + if (!more) { + /* We've converted to a letrec or letrec-values+syntaxes */ + scheme_stx_seal_rib(rib); + rec[drec].env_already = 1; + + if (rec[drec].comp) { + result = scheme_compile_expr(result, env, rec, drec); + return scheme_make_pair(result, scheme_null); + } else { + if (rec[drec].depth > 0) + --rec[drec].depth; + if (rec[drec].depth) { + result = scheme_make_pair(result, scheme_null); + SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result); + return scheme_expand_list(result, env, rec, drec); + } else { + result = scheme_make_pair(result, scheme_null); + return scheme_datum_to_syntax(result, forms, forms, 0, 0); + } + } + } + } + + scheme_stx_seal_rib(rib); + + if (SCHEME_PAIRP(pre_exprs)) + pre_exprs = scheme_reverse(pre_exprs); + + if (rec[drec].comp) { + Scheme_Object *vname, *rest; + + vname = rec[drec].value_name; + scheme_compile_rec_done_local(rec, drec); + scheme_init_compile_recs(rec, drec, recs, 2); + + if (SCHEME_NULLP(pre_exprs)) + rest = SCHEME_STX_CDR(forms); + else { + first = SCHEME_CAR(pre_exprs); + rest = SCHEME_CDR(pre_exprs); + } + + if (SCHEME_STX_NULLP(rest)) + recs[0].value_name = vname; + else + recs[1].value_name = vname; + + rest = scheme_datum_to_syntax(rest, orig, orig, 0, 0); + + first = scheme_compile_expr(first, env, recs, 0); + + forms = scheme_compile_list(rest, env, recs, 1); + + scheme_merge_compile_recs(rec, drec, recs, 2); + return scheme_make_pair(first, forms); + } else { + Scheme_Object *newforms, *vname; + + vname = rec[drec].value_name; + rec[drec].value_name = scheme_false; + scheme_init_expand_recs(rec, drec, recs, 2); + + recs[0].value_name = vname; + + if (SCHEME_PAIRP(pre_exprs)) + newforms = pre_exprs; + else { + newforms = SCHEME_STX_CDR(forms); + newforms = scheme_make_pair(first, newforms); + } + + forms = scheme_datum_to_syntax(newforms, orig, orig, 0, -1); + + if (scheme_stx_proper_list_length(forms) < 0) + scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax"); + + SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms); + forms = scheme_expand_list(forms, env, recs, 0); + return forms; + } +} + +Scheme_Object * +scheme_compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return scheme_compile_expand_block(forms, env, rec, drec, 1); +} + +Scheme_Object * +scheme_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + return scheme_compile_expand_block(forms, env, erec, drec, 1); +} + +Scheme_Object * +scheme_compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + return scheme_compile_expand_block(forms, env, rec, drec, 0); +} + +Scheme_Object * +scheme_expand_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + return scheme_compile_expand_block(forms, env, erec, drec, 0); +} + +Scheme_Object * +scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + Scheme_Object *first = NULL, *last = NULL, *fm; + + SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form); + + if (SCHEME_STX_NULLP(form)) { + SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form); + return scheme_null; + } + + if (scheme_stx_proper_list_length(form) < 0) { + /* This is already checked for anything but application */ + scheme_wrong_syntax(scheme_application_stx_string, NULL, form, + "bad syntax (" IMPROPER_LIST_FORM ")"); + } + + fm = form; + while (SCHEME_STX_PAIRP(fm)) { + Scheme_Object *r, *p; + Scheme_Expand_Info erec1; + + SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); + + p = SCHEME_STX_CDR(fm); + + scheme_init_expand_recs(erec, drec, &erec1, 1); + erec1.value_name = (SCHEME_STX_NULLP(p) ? erec[drec].value_name : scheme_false); + + r = SCHEME_STX_CAR(fm); + r = scheme_expand_expr(r, env, &erec1, 0); + p = scheme_make_pair(r, scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + + fm = SCHEME_STX_CDR(fm); + } + + form = scheme_datum_to_syntax(first, form, form, 0, 0); + SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form); + return form; +} + + +Scheme_Object * +scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto) +{ + Scheme_Object *l, *ll, *a, *name, *body; + + if (scheme_stx_proper_list_length(expr) < 0) + scheme_wrong_syntax(NULL, NULL, expr, "bad syntax (" IMPROPER_LIST_FORM ")"); + + name = SCHEME_STX_CAR(expr); + body = SCHEME_STX_CDR(expr); + + /* Extract body of `begin' and add tracking information */ + l = scheme_copy_list(scheme_flatten_syntax_list(body, NULL)); + for (ll = l; !SCHEME_NULLP(ll); ll = SCHEME_CDR(ll)) { + a = SCHEME_CAR(ll); + a = scheme_stx_track(a, expr, name); + a = scheme_stx_cert(a, NULL, NULL, expr, NULL, 1); + SCHEME_CAR(ll) = a; + } + + return scheme_append(l, append_onto); +} + +/**********************************************************************/ +/* stop expander */ +/**********************************************************************/ + +static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Info *rec, int drec) +{ + scheme_signal_error("internal error: shouldn't get to stop syntax"); + return NULL; +} + +static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) +{ + SCHEME_EXPAND_OBSERVE_PRIM_STOP(erec[drec].observer); + return form; +} + +Scheme_Object *scheme_get_stop_expander(void) +{ + return stop_expander; +} + +void scheme_add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env) +{ + Scheme_Object *stx; + stx = scheme_datum_to_syntax(sym, scheme_false, scheme_sys_wraps(env), 0, 0); + scheme_set_local_syntax(pos, stx, stop_expander, env); +} + +/**********************************************************************/ +/* precise GC */ +/**********************************************************************/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#define MARKS_FOR_COMPILE_C +#include "mzmark.c" + +static void register_traversers(void) +{ +} + +END_XFORM_SKIP; + +#endif diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 7ed1612f26..74b948cc8d 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -37,7 +37,6 @@ #endif #define GLOBAL_TABLE_SIZE 500 -#define TABLE_CACHE_MAX_SIZE 2048 /* #define TIME_STARTUP_PROCESS */ @@ -49,33 +48,13 @@ SHARED_OK int scheme_starting_up; /* globals READ-ONLY SHARED */ READ_ONLY static Scheme_Object *kernel_symbol; -READ_ONLY static Scheme_Object *unshadowable_symbol; READ_ONLY static Scheme_Env *kernel_env; READ_ONLY static Scheme_Env *unsafe_env; READ_ONLY static Scheme_Env *flfxnum_env; READ_ONLY static Scheme_Env *futures_env; -#define MAX_CONST_LOCAL_POS 64 -#define MAX_CONST_LOCAL_TYPES 2 -#define MAX_CONST_LOCAL_FLAG_VAL 3 -#define SCHEME_LOCAL_FLAGS_MASK 0x3 -READ_ONLY static Scheme_Object *scheme_local[MAX_CONST_LOCAL_POS][MAX_CONST_LOCAL_TYPES][MAX_CONST_LOCAL_FLAG_VAL + 1]; -#define MAX_CONST_TOPLEVEL_DEPTH 16 -#define MAX_CONST_TOPLEVEL_POS 16 -#define SCHEME_TOPLEVEL_FLAGS_MASK 0x3 -READ_ONLY static Scheme_Object *toplevels[MAX_CONST_TOPLEVEL_DEPTH][MAX_CONST_TOPLEVEL_POS][SCHEME_TOPLEVEL_FLAGS_MASK + 1]; - -/* If locked, these are probably sharable: */ -THREAD_LOCAL_DECL(static Scheme_Hash_Table *toplevels_ht); -THREAD_LOCAL_DECL(static Scheme_Hash_Table *locals_ht[2]); -THREAD_LOCAL_DECL(static int intdef_counter); -THREAD_LOCAL_DECL(static int builtin_ref_counter); -THREAD_LOCAL_DECL(static int env_uid_counter); - /* local functions */ static void make_kernel_env(void); -static void init_scheme_local(); -static void init_toplevels(); static Scheme_Env *make_env(Scheme_Env *base, int toplevel_size); static Scheme_Env *make_empty_inited_env(int toplevel_size); @@ -128,20 +107,7 @@ static Scheme_Object *make_rename_transformer(int argc, Scheme_Object *argv[]); static Scheme_Object *rename_transformer_target(int argc, Scheme_Object *argv[]); static Scheme_Object *rename_transformer_p(int argc, Scheme_Object *argv[]); -static Scheme_Object *write_toplevel(Scheme_Object *obj); -static Scheme_Object *read_toplevel(Scheme_Object *obj); -static Scheme_Object *write_variable(Scheme_Object *obj); -static Scheme_Object *read_variable(Scheme_Object *obj); -static Scheme_Object *write_module_variable(Scheme_Object *obj); -static Scheme_Object *read_module_variable(Scheme_Object *obj); -static Scheme_Object *write_local(Scheme_Object *obj); -static Scheme_Object *read_local(Scheme_Object *obj); -static Scheme_Object *read_local_unbox(Scheme_Object *obj); -static Scheme_Object *write_resolve_prefix(Scheme_Object *obj); -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj, Scheme_Object *insp); - static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data); -int scheme_is_module_begin_env(Scheme_Comp_Env *env); Scheme_Env *scheme_engine_instance_init(); Scheme_Env *scheme_place_instance_init(); @@ -153,43 +119,11 @@ static void register_traversers(void); typedef Scheme_Object *(*Lazy_Macro_Fun)(Scheme_Object *, int); -#define ARBITRARY_USE 0x1 -#define CONSTRAINED_USE 0x2 -#define WAS_SET_BANGED 0x4 -#define ONE_ARBITRARY_USE 0x8 -/* See also SCHEME_USE_COUNT_MASK */ - -typedef struct Compile_Data { - int num_const; - Scheme_Object **const_names; - Scheme_Object **const_vals; - Scheme_Object **const_uids; - int *sealed; /* NULL => already sealed */ - int *use; - Scheme_Object *lifts; - int min_use, any_use; -} Compile_Data; - -typedef struct Scheme_Full_Comp_Env { - Scheme_Comp_Env base; - Compile_Data data; -} Scheme_Full_Comp_Env; -static void init_compile_data(Scheme_Comp_Env *env); - -/* Precise GC WARNING: this macro produces unaligned pointers: */ -#define COMPILE_DATA(e) (&((Scheme_Full_Comp_Env *)e)->data) - -#define SCHEME_NON_SIMPLE_FRAME (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME \ - | SCHEME_FOR_STOPS | SCHEME_CAPTURE_LIFTED) - -#define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ - /*========================================================================*/ /* initialization */ /*========================================================================*/ - static void boot_module_resolver() { Scheme_Object *boot, *a[2]; @@ -314,8 +248,11 @@ Scheme_Env *scheme_engine_instance_init() { scheme_starting_up = 1; scheme_init_portable_case(); - init_scheme_local(); - init_toplevels(); + scheme_init_compenv(); + scheme_init_optimize(); + scheme_init_resolve(); + scheme_init_sfs(); + scheme_init_validate(); scheme_init_process_globals(); @@ -605,7 +542,6 @@ static void make_kernel_env(void) env = make_empty_inited_env(GLOBAL_TABLE_SIZE); - REGISTER_SO(kernel_env); kernel_env = env; @@ -720,25 +656,8 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("syntax-local-lift-require", local_lift_require, 2, 2, env); GLOBAL_PRIM_W_ARITY("syntax-local-lift-provide", local_lift_provide, 1, 1, env); - - REGISTER_SO(unshadowable_symbol); - unshadowable_symbol = scheme_intern_symbol("unshadowable"); - DONE_TIME(env); - scheme_install_type_writer(scheme_toplevel_type, write_toplevel); - scheme_install_type_reader(scheme_toplevel_type, read_toplevel); - scheme_install_type_writer(scheme_variable_type, write_variable); - scheme_install_type_reader(scheme_variable_type, read_variable); - scheme_install_type_writer(scheme_module_variable_type, write_module_variable); - scheme_install_type_reader(scheme_module_variable_type, read_module_variable); - scheme_install_type_writer(scheme_local_type, write_local); - scheme_install_type_reader(scheme_local_type, read_local); - scheme_install_type_writer(scheme_local_unbox_type, write_local); - scheme_install_type_reader(scheme_local_unbox_type, read_local_unbox); - scheme_install_type_writer(scheme_resolve_prefix_type, write_resolve_prefix); - scheme_install_type_reader2(scheme_resolve_prefix_type, read_resolve_prefix); - register_network_evts(); REGISTER_SO(kernel_symbol); @@ -775,86 +694,6 @@ Scheme_Env *scheme_get_kernel_env() { return kernel_env; } -static void init_scheme_local() -{ - int i, k, cor; - -#ifndef USE_TAGGED_ALLOCATION - GC_CAN_IGNORE Scheme_Local *all; - - all = (Scheme_Local *)scheme_malloc_eternal(sizeof(Scheme_Local) - * (MAX_CONST_LOCAL_FLAG_VAL + 1) - * MAX_CONST_LOCAL_TYPES - * MAX_CONST_LOCAL_POS); -# ifdef MEMORY_COUNTING_ON - scheme_misc_count += (sizeof(Scheme_Local) - * (MAX_CONST_LOCAL_FLAG_VAL + 1) - * MAX_CONST_LOCAL_TYPES - * MAX_CONST_LOCAL_POS); -# endif -#endif - - for (i = 0; i < MAX_CONST_LOCAL_POS; i++) { - for (k = 0; k < MAX_CONST_LOCAL_TYPES; k++) { - for (cor = 0; cor < (MAX_CONST_LOCAL_FLAG_VAL + 1); cor++) { - Scheme_Object *v; - -#ifndef USE_TAGGED_ALLOCATION - v = (Scheme_Object *)(all++); -#else - v = (Scheme_Object *)scheme_malloc_eternal_tagged(sizeof(Scheme_Local)); -#endif - v->type = k + scheme_local_type; - SCHEME_LOCAL_POS(v) = i; - SCHEME_LOCAL_FLAGS(v) = cor; - - scheme_local[i][k][cor] = v; - } - } - } -} - -static void init_toplevels() -{ - int i, k, cnst; - -#ifndef USE_TAGGED_ALLOCATION - GC_CAN_IGNORE Scheme_Toplevel *all; - - all = (Scheme_Toplevel *)scheme_malloc_eternal(sizeof(Scheme_Toplevel) - * MAX_CONST_TOPLEVEL_DEPTH - * MAX_CONST_TOPLEVEL_POS - * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); -# ifdef MEMORY_COUNTING_ON - scheme_misc_count += (sizeof(Scheme_Toplevel) - * MAX_CONST_TOPLEVEL_DEPTH - * MAX_CONST_TOPLEVEL_POS - * (SCHEME_TOPLEVEL_FLAGS_MASK + 1)); -# endif -#endif - - for (i = 0; i < MAX_CONST_TOPLEVEL_DEPTH; i++) { - for (k = 0; k < MAX_CONST_TOPLEVEL_POS; k++) { - for (cnst = 0; cnst <= SCHEME_TOPLEVEL_FLAGS_MASK; cnst++) { - Scheme_Toplevel *v; - -#ifndef USE_TAGGED_ALLOCATION - v = (all++); -#else - v = (Scheme_Toplevel *)scheme_malloc_eternal_tagged(sizeof(Scheme_Toplevel)); -#endif - v->iso.so.type = scheme_toplevel_type; - v->depth = i; - v->position = k; - SCHEME_TOPLEVEL_FLAGS(v) = cnst; - - toplevels[i][k][cnst] = (Scheme_Object *)v; - } - } - } -} - - /* Shutdown procedure for resetting a namespace: */ static void skip_certain_things(Scheme_Object *o, Scheme_Close_Custodian_Client *f, void *data) { @@ -1539,2930 +1378,6 @@ const char *scheme_look_for_primitive(void *code) return NULL; } -/*========================================================================*/ -/* compile-time env, constructors and simple queries */ -/*========================================================================*/ - -static void init_compile_data(Scheme_Comp_Env *env) -{ - Compile_Data *data; - int i, c, *use; - - c = env->num_bindings; - if (c) - use = MALLOC_N_ATOMIC(int, c); - else - use = NULL; - - data = COMPILE_DATA(env); - - data->use = use; - for (i = 0; i < c; i++) { - use[i] = 0; - } - - data->min_use = c; -} - -Scheme_Comp_Env *scheme_new_compilation_frame(int num_bindings, int flags, - Scheme_Comp_Env *base, Scheme_Object *certs) -{ - Scheme_Comp_Env *frame; - int count; - - count = num_bindings; - - frame = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env); -#ifdef MZTAG_REQUIRED - frame->type = scheme_rt_comp_env; -#endif - - { - Scheme_Object **vals; - vals = MALLOC_N(Scheme_Object *, count); - frame->values = vals; - } - - frame->certs = certs; - frame->num_bindings = num_bindings; - frame->flags = flags | (base->flags & SCHEME_NO_RENAME); - frame->next = base; - frame->genv = base->genv; - frame->insp = base->insp; - frame->prefix = base->prefix; - frame->in_modidx = base->in_modidx; - - if (flags & SCHEME_NON_SIMPLE_FRAME) - frame->skip_depth = 0; - else if (base->next) - frame->skip_depth = base->skip_depth + 1; - else - frame->skip_depth = 0; - - init_compile_data(frame); - - return frame; -} - -Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int flags) -{ - Scheme_Comp_Env *e; - Comp_Prefix *cp; - - if (!insp) - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - e = (Scheme_Comp_Env *)MALLOC_ONE_RT(Scheme_Full_Comp_Env); -#ifdef MZTAG_REQUIRED - e->type = scheme_rt_comp_env; -#endif - e->num_bindings = 0; - e->next = NULL; - e->genv = genv; - e->insp = insp; - e->flags = flags; - init_compile_data(e); - - cp = MALLOC_ONE_RT(Comp_Prefix); -#ifdef MZTAG_REQUIRED - cp->type = scheme_rt_comp_prefix; -#endif - - e->prefix = cp; - - return e; -} - -Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, int flags) -{ - Scheme_Comp_Env *e; - - e = scheme_new_comp_env(genv, insp, flags); - e->prefix = NULL; - - return e; -} - -int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env) -{ - Scheme_Comp_Env *se; - - for (se = stx_env; NOT_SAME_OBJ(se, env); se = se->next) { - if (!(se->flags & SCHEME_FOR_INTDEF)) - break; - } - return SAME_OBJ(se, env); -} - -int scheme_used_ever(Scheme_Comp_Env *env, int which) -{ - Compile_Data *data = COMPILE_DATA(env); - - return !!data->use[which]; -} - -int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which) -{ - Compile_Data *data = COMPILE_DATA(env); - - return !!(data->use[which] & WAS_SET_BANGED); -} - -void -scheme_add_compilation_binding(int index, Scheme_Object *val, Scheme_Comp_Env *frame) -{ - if ((index >= frame->num_bindings) || (index < 0)) - scheme_signal_error("internal error: scheme_add_binding: " - "index out of range: %d", index); - - frame->values[index] = val; - frame->skip_table = NULL; -} - -void scheme_frame_captures_lifts(Scheme_Comp_Env *env, Scheme_Lift_Capture_Proc cp, Scheme_Object *data, - Scheme_Object *end_stmts, Scheme_Object *context_key, - Scheme_Object *requires, Scheme_Object *provides) -{ - Scheme_Lift_Capture_Proc *pp; - Scheme_Object *vec; - - pp = (Scheme_Lift_Capture_Proc *)scheme_malloc_atomic(sizeof(Scheme_Lift_Capture_Proc)); - *pp = cp; - - vec = scheme_make_vector(8, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_null; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)pp; - SCHEME_VEC_ELS(vec)[2] = data; - SCHEME_VEC_ELS(vec)[3] = end_stmts; - SCHEME_VEC_ELS(vec)[4] = context_key; - SCHEME_VEC_ELS(vec)[5] = (requires ? requires : scheme_false); - SCHEME_VEC_ELS(vec)[6] = scheme_null; /* accumulated requires */ - SCHEME_VEC_ELS(vec)[7] = provides; - - COMPILE_DATA(env)->lifts = vec; -} - -void scheme_propagate_require_lift_capture(Scheme_Comp_Env *orig_env, Scheme_Comp_Env *env) -{ - while (orig_env) { - if ((COMPILE_DATA(orig_env)->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(orig_env)->lifts)[5])) - break; - orig_env = orig_env->next; - } - - if (orig_env) { - Scheme_Object *vec, *p; - - p = scheme_make_raw_pair(NULL, (Scheme_Object *)orig_env); - - vec = scheme_make_vector(8, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_false; - SCHEME_VEC_ELS(vec)[1] = scheme_void; - SCHEME_VEC_ELS(vec)[2] = scheme_void; - SCHEME_VEC_ELS(vec)[3] = scheme_false; - SCHEME_VEC_ELS(vec)[4] = scheme_false; - SCHEME_VEC_ELS(vec)[5] = p; /* (rcons NULL env) => continue with env */ - SCHEME_VEC_ELS(vec)[6] = scheme_null; - SCHEME_VEC_ELS(vec)[7] = scheme_false; - - COMPILE_DATA(env)->lifts = vec; - } -} - -Scheme_Object *scheme_frame_get_lifts(Scheme_Comp_Env *env) -{ - return scheme_reverse(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0]); -} - -Scheme_Object *scheme_frame_get_end_statement_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]; -} - -Scheme_Object *scheme_frame_get_require_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]; -} - -Scheme_Object *scheme_frame_get_provide_lifts(Scheme_Comp_Env *env) -{ - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]; -} - -void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env) -{ - Scheme_Object **ns, **vs; - - if (cnt) { - ns = MALLOC_N(Scheme_Object *, cnt); - vs = MALLOC_N(Scheme_Object *, cnt); - - COMPILE_DATA(env)->num_const = cnt; - COMPILE_DATA(env)->const_names = ns; - COMPILE_DATA(env)->const_vals = vs; - - } -} - -void scheme_set_local_syntax(int pos, - Scheme_Object *name, Scheme_Object *val, - Scheme_Comp_Env *env) -{ - COMPILE_DATA(env)->const_names[pos] = name; - COMPILE_DATA(env)->const_vals[pos] = val; - env->skip_table = NULL; -} - -Scheme_Comp_Env * -scheme_add_compilation_frame(Scheme_Object *vals, Scheme_Comp_Env *env, int flags, Scheme_Object *certs) -{ - Scheme_Comp_Env *frame; - int len, i, count; - - len = scheme_stx_list_length(vals); - count = len; - - frame = scheme_new_compilation_frame(count, flags, env, certs); - - for (i = 0; i < len ; i++) { - if (SCHEME_STX_SYMBOLP(vals)) - frame->values[i] = vals; - else { - Scheme_Object *a; - a = SCHEME_STX_CAR(vals); - frame->values[i] = a; - vals = SCHEME_STX_CDR(vals); - } - } - - init_compile_data(frame); - - return frame; -} - -Scheme_Comp_Env *scheme_no_defines(Scheme_Comp_Env *env) -{ - if (scheme_is_toplevel(env) - || scheme_is_module_env(env) - || scheme_is_module_begin_env(env) - || (env->flags & SCHEME_INTDEF_FRAME)) - return scheme_new_compilation_frame(0, 0, env, NULL); - else - return env; -} - -Scheme_Comp_Env *scheme_require_renames(Scheme_Comp_Env *env) -{ - if (env->flags & SCHEME_NO_RENAME) { - env = scheme_new_compilation_frame(0, 0, env, NULL); - env->flags -= SCHEME_NO_RENAME; - } - - return env; -} - -int scheme_is_toplevel(Scheme_Comp_Env *env) -{ - return !env->next || (env->flags & SCHEME_TOPLEVEL_FRAME); -} - -int scheme_is_module_env(Scheme_Comp_Env *env) -{ - return !!(env->flags & SCHEME_MODULE_BEGIN_FRAME); /* name is backwards compared to symbol! */ -} - -int scheme_is_module_begin_env(Scheme_Comp_Env *env) -{ - return !!(env->flags & SCHEME_MODULE_FRAME); /* name is backwards compared to symbol! */ -} - -Scheme_Comp_Env *scheme_extend_as_toplevel(Scheme_Comp_Env *env) -{ - if (scheme_is_toplevel(env)) - return env; - else - return scheme_new_compilation_frame(0, SCHEME_TOPLEVEL_FRAME, env, NULL); -} - -static Scheme_Object *make_toplevel(mzshort depth, int position, int resolved, int flags) -{ - Scheme_Toplevel *tl; - Scheme_Object *v, *pr; - - /* Important: non-resolved can't be cached, because the ISCONST - field is modified to track mutated module-level variables. But - the value for a specific toplevel is cached in the environment - layer. */ - - if (resolved) { - if ((depth < MAX_CONST_TOPLEVEL_DEPTH) - && (position < MAX_CONST_TOPLEVEL_POS)) - return toplevels[depth][position][flags]; - - if ((position < 0xFFFF) && (depth < 0xFF)) { - int ep = position | (depth << 16) | (flags << 24); - pr = scheme_make_integer(ep); - } else { - pr = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(pr)[0] = scheme_make_integer(position); - SCHEME_VEC_ELS(pr)[1] = scheme_make_integer(flags); - SCHEME_VEC_ELS(pr)[2] = scheme_make_integer(depth); - } - v = scheme_hash_get_atomic(toplevels_ht, pr); - if (v) - return v; - } else - pr = NULL; - - tl = (Scheme_Toplevel *)scheme_malloc_atomic_tagged(sizeof(Scheme_Toplevel)); - tl->iso.so.type = (resolved ? scheme_toplevel_type : scheme_compiled_toplevel_type); - tl->depth = depth; - tl->position = position; - SCHEME_TOPLEVEL_FLAGS(tl) = flags; - - if (resolved) { - if (toplevels_ht->count > TABLE_CACHE_MAX_SIZE) { - toplevels_ht = scheme_make_hash_table_equal(); - } - scheme_hash_set_atomic(toplevels_ht, pr, (Scheme_Object *)tl); - } - - return (Scheme_Object *)tl; -} - -Scheme_Object *scheme_register_toplevel_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - int imported) -{ - Comp_Prefix *cp = env->prefix; - Scheme_Hash_Table *ht; - Scheme_Object *o; - - if (rec && rec[drec].dont_mark_local_use) { - /* Make up anything; it's going to be ignored. */ - return make_toplevel(0, 0, 0, 0); - } - - ht = cp->toplevels; - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->toplevels = ht; - } - - o = scheme_hash_get(ht, var); - if (o) - return o; - - o = make_toplevel(0, cp->num_toplevels, 0, imported ? SCHEME_TOPLEVEL_READY : 0); - - cp->num_toplevels++; - scheme_hash_set(ht, var, o); - - return o; -} - -Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *_tl, int flags) -{ - Scheme_Toplevel *tl = (Scheme_Toplevel *)_tl; - return make_toplevel(tl->depth, tl->position, 0, flags); -} - -Scheme_Object *scheme_register_stx_in_prefix(Scheme_Object *var, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - Comp_Prefix *cp = env->prefix; - Scheme_Local *l; - Scheme_Object *o; - int pos; - - if (rec && rec[drec].dont_mark_local_use) { - /* Make up anything; it's going to be ignored. */ - l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - l->iso.so.type = scheme_compiled_quote_syntax_type; - l->position = 0; - - return (Scheme_Object *)l; - } - - if (!cp->stxes) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - cp->stxes = ht; - } - - pos = cp->num_stxes; - - l = (Scheme_Local *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - l->iso.so.type = scheme_compiled_quote_syntax_type; - l->position = pos; - - cp->num_stxes++; - o = (Scheme_Object *)l; - - scheme_hash_set(cp->stxes, var, o); - - return o; -} - -void scheme_register_unsafe_in_prefix(Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, - Scheme_Env *menv) -{ - Scheme_Object *v, *insp; - - if (rec && rec[drec].dont_mark_local_use) { - return; - } - - insp = menv->module->insp; - - v = env->prefix->uses_unsafe; - if (!v) - v = insp; - else if (!SAME_OBJ(v, insp)) { - Scheme_Hash_Tree *ht; - - if (SCHEME_HASHTRP(v)) { - ht = (Scheme_Hash_Tree *)v; - } else { - ht = scheme_make_hash_tree(0); - ht = scheme_hash_tree_set(ht, v, scheme_true); - } - - if (!scheme_hash_tree_get(ht, insp)) { - ht = scheme_hash_tree_set(ht, insp, scheme_true); - env->prefix->uses_unsafe = (Scheme_Object *)ht; - } - } -} - -/*========================================================================*/ -/* compile-time env, lookup bindings */ -/*========================================================================*/ - -static Scheme_Object *alloc_local(short type, int pos) -{ - Scheme_Object *v; - - v = (Scheme_Object *)scheme_malloc_atomic_tagged(sizeof(Scheme_Local)); - v->type = type; - SCHEME_LOCAL_POS(v) = pos; - - return (Scheme_Object *)v; -} - -Scheme_Object *scheme_make_local(Scheme_Type type, int pos, int flags) -{ - int k; - Scheme_Object *v, *key; - - k = type - scheme_local_type; - - /* Helper for reading bytecode: make sure flags is a valid value */ - switch (flags) { - case 0: - case SCHEME_LOCAL_CLEAR_ON_READ: - case SCHEME_LOCAL_OTHER_CLEARS: - case SCHEME_LOCAL_FLONUM: - break; - default: - flags = SCHEME_LOCAL_OTHER_CLEARS; - break; - } - - if (pos < MAX_CONST_LOCAL_POS) { - return scheme_local[pos][k][flags]; - } - - key = scheme_make_integer(pos); - if (flags) { - key = scheme_make_pair(scheme_make_integer(flags), key); - } - - v = scheme_hash_get(locals_ht[k], key); - if (v) - return v; - - v = alloc_local(type, pos); - SCHEME_LOCAL_FLAGS(v) = flags; - - if (locals_ht[k]->count > TABLE_CACHE_MAX_SIZE) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - locals_ht[k] = ht; - } - - scheme_hash_set(locals_ht[k], key, v); - - return v; -} - -static Scheme_Local *get_frame_loc(Scheme_Comp_Env *frame, - int i, int j, int p, int flags) -/* Generates a Scheme_Local record for a static distance coodinate, and also - marks the variable as used for closures. */ -{ - int cnt, u; - - u = COMPILE_DATA(frame)->use[i]; - - u |= (((flags & (SCHEME_APP_POS | SCHEME_SETTING | SCHEME_REFERENCING)) - ? CONSTRAINED_USE - : ((u & (ARBITRARY_USE | ONE_ARBITRARY_USE)) ? ARBITRARY_USE : ONE_ARBITRARY_USE)) - | ((flags & (SCHEME_SETTING | SCHEME_REFERENCING | SCHEME_LINKING_REF)) - ? WAS_SET_BANGED - : 0)); - - cnt = ((u & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); - if (cnt < SCHEME_USE_COUNT_INF) - cnt++; - u -= (u & SCHEME_USE_COUNT_MASK); - u |= (cnt << SCHEME_USE_COUNT_SHIFT); - - COMPILE_DATA(frame)->use[i] = u; - if (i < COMPILE_DATA(frame)->min_use) - COMPILE_DATA(frame)->min_use = i; - COMPILE_DATA(frame)->any_use = 1; - - return (Scheme_Local *)scheme_make_local(scheme_local_type, p + i, 0); -} - -Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modidx, - Scheme_Object *stxsym, Scheme_Object *insp, - int pos, intptr_t mod_phase) -{ - Scheme_Object *val; - Scheme_Hash_Table *ht; - - if (!env->modvars) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - env->modvars = ht; - } - - stxsym = SCHEME_STX_SYM(stxsym); - - ht = (Scheme_Hash_Table *)scheme_hash_get(env->modvars, modidx); - - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(env->modvars, modidx, (Scheme_Object *)ht); - } - - /* Loop for inspector-specific hash table, maybe: */ - while (1) { - - val = scheme_hash_get(ht, stxsym); - - if (!val) { - Module_Variable *mv; - - mv = MALLOC_ONE_TAGGED(Module_Variable); - mv->so.type = scheme_module_variable_type; - - mv->modidx = modidx; - mv->sym = stxsym; - mv->insp = insp; - mv->pos = pos; - mv->mod_phase = (int)mod_phase; - - val = (Scheme_Object *)mv; - - scheme_hash_set(ht, stxsym, val); - - break; - } else { - /* Check that inspector is the same. */ - Module_Variable *mv = (Module_Variable *)val; - - if (!SAME_OBJ(mv->insp, insp)) { - /* Need binding for a different inspector. Try again. */ - val = scheme_hash_get(ht, insp); - if (!val) { - Scheme_Hash_Table *ht2; - /* Make a table for this specific inspector */ - ht2 = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(ht, insp, (Scheme_Object *)ht2); - ht = ht2; - /* loop... */ - } else - ht = (Scheme_Hash_Table *)val; - } else - break; - } - } - - return val; -} - -Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, - int mode, /* -1, 0 => lookup; 2, 3 => define - -1 and 3 => use temp table - 1 would mean define if no match; not currently used */ - Scheme_Object *phase, int *_skipped) -/* The `env' argument can actually be a hash table. */ -{ - Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg; - int best_match_skipped, ms, one_mark; - Scheme_Hash_Table *marked_names, *temp_marked_names, *dest_marked_names; - - sym = SCHEME_STX_SYM(id); - - if (_skipped) - *_skipped = -1; - - if (SCHEME_HASHTP((Scheme_Object *)env)) { - marked_names = (Scheme_Hash_Table *)env; - temp_marked_names = NULL; - } else { - /* If there's no table and we're not defining, bail out fast */ - if ((mode <= 0) && !env->rename_set) - return sym; - marked_names = scheme_get_module_rename_marked_names(env->rename_set, - phase ? phase : scheme_make_integer(env->phase), - 0); - temp_marked_names = env->temp_marked_names; - } - - if (mode > 0) { - /* If we're defining, see if we need to create a table. Getting - marks is relatively expensive, but we only do this once per - definition. */ - if (!bdg) - bdg = scheme_stx_moduleless_env(id); - marks = scheme_stx_extract_marks(id); - if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg)) - return sym; - } - - if (!marked_names) { - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - marked_names = scheme_get_module_rename_marked_names(env->rename_set, - phase ? phase : scheme_make_integer(env->phase), - 1); - } - if (!temp_marked_names && (mode > 2)) { - /* The "temp" marked name table is used to correlate marked module - requires with similarly marked provides. We don't go through - the normal rename table because (for efficiency) the marks in - this case are handled more directly in the shared_pes module - renamings. */ - temp_marked_names = scheme_make_hash_table(SCHEME_hash_ptr); - env->temp_marked_names = temp_marked_names; - } - - map = scheme_hash_get(marked_names, sym); - if (!map && ((mode < 0) || (mode > 2)) && temp_marked_names) - map = scheme_hash_get(temp_marked_names, sym); - - if (!map) { - /* If we're not defining, we can bail out before extracting marks. */ - if (mode <= 0) - return sym; - else - map = scheme_null; - } - - if (!bdg) { - /* We need lexical binding, if any, too: */ - bdg = scheme_stx_moduleless_env(id); - } - - if (!marks) { - /* We really do need the marks. Get them. */ - marks = scheme_stx_extract_marks(id); - if (SCHEME_NULLP(marks) && SCHEME_FALSEP(bdg)) - return sym; - } - - best_match = NULL; - best_match_skipped = scheme_list_length(marks); - if (best_match_skipped == 1) { - /* A mark list of length 1 is the common case. - Since the list is otherwise marshaled into .zo, etc., - simplify by extracting just the mark: */ - marks = SCHEME_CAR(marks); - one_mark = 1; - } else - one_mark = 0; - - if (!SCHEME_TRUEP(bdg)) - bdg = NULL; - - /* Find a mapping that matches the longest tail of marks */ - for (l = map; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - amarks = SCHEME_CAR(a); - - if (SCHEME_VECTORP(amarks)) { - abdg = SCHEME_VEC_ELS(amarks)[1]; - amarks = SCHEME_VEC_ELS(amarks)[0]; - } else - abdg = NULL; - - if (SAME_OBJ(abdg, bdg)) { - if (mode > 0) { - if (scheme_equal(amarks, marks)) { - best_match = SCHEME_CDR(a); - break; - } - } else { - if (!SCHEME_PAIRP(marks)) { - /* To be better than nothing, could only match exactly: */ - if (scheme_equal(amarks, marks) - || SCHEME_NULLP(amarks)) { - best_match = SCHEME_CDR(a); - best_match_skipped = 0; - } - } else { - /* amarks can match a tail of marks: */ - for (m = marks, ms = 0; - SCHEME_PAIRP(m) && (ms < best_match_skipped); - m = SCHEME_CDR(m), ms++) { - - cm = m; - if (!SCHEME_PAIRP(amarks)) { - /* If we're down to the last element - of marks, then extract it to try to - match the symbol amarks. */ - if (SCHEME_NULLP(SCHEME_CDR(m))) - cm = SCHEME_CAR(m); - } - - if (scheme_equal(amarks, cm)) { - best_match = SCHEME_CDR(a); - best_match_skipped = ms; - break; - } - } - } - } - } - } - - if (!best_match) { - if (mode <= 0) { - return sym; - } - - /* Last chance before making up a new name. If we're processing a - module body generated by `expand', then we picked a name last - time around. We can't pick a new name now, otherwise - "redundant" module renamings wouldn't be redundant. (See - simpify in stxobj.c.) So check for a context-determined - existing rename. */ - if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { - Scheme_Object *mod, *nm = id; - mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL, NULL); - if (mod /* must refer to env->module, otherwise there would - have been an error before getting here */ - && NOT_SAME_OBJ(nm, sym)) - /* It has a rename already! */ - best_match = nm; - } - - /* Adding a definition. We "gensym" here in a sense; actually, we - use a symbol table that's in parallel to the normal table, so - that we get the same parallel-symbol when unmarshalling - code. We use a counter attached to the environment. Normally, - this counter just increments, but if a module is re-expanded, - then the counter starts at 0 for the re-expand, and we may - re-pick an existing name. To avoid re-picking the same name, - double-check for a mapping in the environment by inspecting the - renames attached to id. In the top-level environment, it's - still possible to get a collision, because separately compiled - code might be loaded into the same environment (which is just - too bad). */ - if (!best_match) { - char onstack[50], *buf; - intptr_t len; - - while (1) { - env->id_counter++; - len = SCHEME_SYM_LEN(sym); - if (len <= 35) - buf = onstack; - else - buf = scheme_malloc_atomic(len + 15); - memcpy(buf, SCHEME_SYM_VAL(sym), len); - - /* The dot here is significant; it might gets stripped away when - printing the symbol */ - sprintf(buf XFORM_OK_PLUS len, ".%d", env->id_counter); - - best_match = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); - - if (!scheme_stx_parallel_is_used(best_match, id)) { - /* Also check environment's rename tables. This last check - includes the temp table. It also turns out to matter for - compiling in `module->namespace' contexts, because no - renaming is added after expansion to record the rename - table. */ - if (!scheme_tl_id_is_sym_used(marked_names, best_match) - && (!temp_marked_names - || !scheme_tl_id_is_sym_used(temp_marked_names, best_match))) { - /* Ok, no matches, so this name is fine. */ - break; - } - } - - /* Otherwise, increment counter and try again... */ - } - } - if (bdg) { - a = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(a)[0] = marks; - SCHEME_VEC_ELS(a)[1] = bdg; - marks = a; - } - a = scheme_make_pair(marks, best_match); - map = scheme_make_pair(a, map); - - dest_marked_names = ((mode < 0) || (mode > 2)) ? temp_marked_names : marked_names; - scheme_hash_set(dest_marked_names, sym, map); - { - Scheme_Hash_Table *rev_ht; - rev_ht = (Scheme_Hash_Table *)scheme_hash_get(dest_marked_names, scheme_false); - if (rev_ht) { - scheme_hash_set(rev_ht, best_match, scheme_true); - } - } - } else { - if (_skipped) - *_skipped = best_match_skipped; - } - - return best_match; -} - -int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym) -{ - intptr_t i; - Scheme_Object *l, *a; - Scheme_Hash_Table *rev_ht; - - if (!marked_names) - return 0; - - if (!marked_names->count) - return 0; - - rev_ht = (Scheme_Hash_Table *)scheme_hash_get(marked_names, scheme_false); - - if (!rev_ht) { - rev_ht = scheme_make_hash_table(SCHEME_hash_ptr); - - for (i = marked_names->size; i--; ) { - l = marked_names->vals[i]; - if (l) { - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - scheme_hash_set(rev_ht, SCHEME_CDR(a), scheme_true); - } - } - scheme_hash_set(marked_names, scheme_false, (Scheme_Object *)rev_ht); - } - } - - if (scheme_hash_get(rev_ht, sym)) - return 1; - - return 0; -} - -static Scheme_Object *make_uid() -{ - char name[20]; - - sprintf(name, "env%d", env_uid_counter++); - return scheme_make_symbol(name); /* uninterned! */ -} - -Scheme_Object *scheme_env_frame_uid(Scheme_Comp_Env *env) -{ - if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED)) - return NULL; - - if (!env->uid) { - Scheme_Object *sym; - sym = make_uid(); - env->uid = sym; - } - return env->uid; -} - -static void make_env_renames(Scheme_Comp_Env *env, int rcount, int rstart, int rstart_sec, int force_multi, - Scheme_Object *stx) -{ - Scheme_Object *rnm; - Scheme_Object *uid = NULL; - int i, pos; - - if (env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED)) - return; - - scheme_env_frame_uid(env); - - if (force_multi) { - if (env->num_bindings && !env->uids) { - Scheme_Object **uids; - uids = MALLOC_N(Scheme_Object *, env->num_bindings); - env->uids = uids; - } - if (COMPILE_DATA(env)->num_const && !COMPILE_DATA(env)->const_uids) { - Scheme_Object **cuids; - cuids = MALLOC_N(Scheme_Object *, COMPILE_DATA(env)->num_const); - COMPILE_DATA(env)->const_uids = cuids; - } - if (env->uid && !SCHEME_FALSEP(env->uid)) { - uid = env->uid; - env->uid = scheme_false; - } - } - - if (!uid) { - if (env->uid && SCHEME_TRUEP(env->uid)) { - /* single-uid mode (at least for now) */ - uid = env->uid; - } else { - /* multi-uid mode */ - if (!rstart_sec) - uid = COMPILE_DATA(env)->const_uids[rstart]; - else - uid = env->uids[rstart]; - if (!uid) - uid = make_uid(); - } - } - - rnm = scheme_make_rename(uid, rcount); - pos = 0; - - if (!rstart_sec) { - for (i = rstart; (i < COMPILE_DATA(env)->num_const) && (pos < rcount); i++, pos++) { - if (COMPILE_DATA(env)->const_uids) - COMPILE_DATA(env)->const_uids[i] = uid; - scheme_set_rename(rnm, pos, COMPILE_DATA(env)->const_names[i]); - } - rstart = 0; - } - for (i = rstart; pos < rcount; i++, pos++) { - if (env->uids) - env->uids[i] = uid; - scheme_set_rename(rnm, pos, env->values[i]); - } - - if (SCHEME_RIBP(stx)) - scheme_add_rib_rename(stx, rnm); - - if (env->renames) { - if (SCHEME_PAIRP(env->renames) || SCHEME_NULLP(env->renames)) - rnm = scheme_make_pair(rnm, env->renames); - else - rnm = scheme_make_pair(rnm, scheme_make_pair(env->renames, scheme_null)); - } - env->renames = rnm; -} - -Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env, - Scheme_Comp_Env *upto) -{ - if (!SCHEME_STXP(stx) && !SCHEME_RIBP(stx)) { - scheme_signal_error("internal error: not syntax or rib"); - return NULL; - } - - if (SCHEME_RIBP(stx)) { - GC_CAN_IGNORE int *s; - s = scheme_stx_get_rib_sealed(stx); - COMPILE_DATA(env)->sealed = s; - } - - while (env != upto) { - if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME - | SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) { - int i, count; - - /* How many slots filled in the frame so far? This can change - due to the style of let* compilation, which generates a - rename record after each binding set. The "const" bindings - are always all in place before we generate any renames in - that case. However, the "const" bindings can grow by - themselves before non-const bindings are installed. */ - count = COMPILE_DATA(env)->num_const; - for (i = env->num_bindings; i--; ) { - if (env->values[i]) - count++; - } - - if (count) { - Scheme_Object *l; - - if (!env->renames || (env->rename_var_count != count)) { - /* Need to create lexical renaming record(s). We create - multiple records as necessary to avoid uids that contain - more than one variable with the same symbol name. - - This is complicated, because we don't want to allocate a - hash table in the common case of a binding set with a few - names. It's also complicated by incremental rename - building: if env->rename_var_count is not zero, we've - done this before for a subset of `values' (and there are - no consts in that case). In the incremental case, we have - a dup_check hash table left from the previous round. */ - Scheme_Hash_Table *ht; - Scheme_Object *name; - int rcount = 0, rstart, rstart_sec = 0, vstart; - - /* rstart is where the to-be-created rename table starts - (saved from last time around, or initially zero). - vstart is where we start looking for new dups. - rstart_sec is TRUE when the new frame starts in the - non-constant area. */ - rstart = env->rename_rstart; - if (env->renames) { - /* Incremental mode. Drop the most recent (first) rename - table, because we'll recreate it: */ - if (SCHEME_PAIRP(env->renames)) - env->renames = SCHEME_CDR(env->renames); - else - env->renames = NULL; - if (SCHEME_RIBP(stx)) - scheme_drop_first_rib_rename(stx); - vstart = env->rename_var_count; - rstart_sec = 1; - /* We already know that the first rcount - are distinct (from the last iteration) */ - rcount = vstart - rstart; - } else - vstart = 0; - - /* Create or find the hash table: */ - if (env->dup_check) - ht = env->dup_check; - else if (env->num_bindings + COMPILE_DATA(env)->num_const > 10) - ht = scheme_make_hash_table(SCHEME_hash_ptr); - else - ht = NULL; - - if (rcount > 16) { - /* Instead of n^2 growth for the rename, just close the current - one off and start fresh. */ - make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); - rcount = 0; - rstart = vstart; - rstart_sec = 1; - if (ht) { - /* Flush the table for a new set: */ - ht = scheme_make_hash_table(SCHEME_hash_ptr); - } - } - - /* Check for dups among the statics, and build a rename for - each dup-free set. */ - - /* First: constants. */ - if (!rstart_sec) { - if (COMPILE_DATA(env)->num_const) { - /* Start at the beginning, always. */ - for (i = 0; i < COMPILE_DATA(env)->num_const; i++) { - int found = 0; - name = SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[i]); - if (ht) { - if (scheme_hash_get(ht, name)) - found = 1; - else - scheme_hash_set(ht, name, scheme_true); - } else { - int j; - for (j = rstart; j < i; j++) { - if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) { - found = 1; - break; - } - } - } - - if (found) { - make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); - rcount = 1; - rstart = i; - if (ht) { - /* Flush the table for a new set: */ - ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(ht, name, scheme_true); - } - } else - rcount++; - } - } else - rstart_sec = 1; - } - - for (i = vstart; (i < env->num_bindings) && env->values[i]; i++) { - int found = 0; - name = SCHEME_STX_VAL(env->values[i]); - - if (ht) { - if (scheme_hash_get(ht, name)) - found = 1; - else - scheme_hash_set(ht, name, scheme_true); - } else { - int j; - if (!rstart_sec) { - /* Look in consts, first: */ - for (j = rstart; j < COMPILE_DATA(env)->num_const; j++) { - if (SAME_OBJ(name, SCHEME_STX_VAL(COMPILE_DATA(env)->const_names[j]))) { - found = 1; - break; - } - } - - j = 0; - } else - j = rstart; - - if (!found) { - for (; j < i; j++) { - if (SAME_OBJ(name, SCHEME_STX_VAL(env->values[j]))) { - found = 1; - break; - } - } - } - } - - if (found) { - make_env_renames(env, rcount, rstart, rstart_sec, 1, stx); - rcount = 1; - rstart = i; - rstart_sec = 1; - if (ht) { - /* Flush the table for a new set: */ - ht = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(ht, name, scheme_true); - } - } else - rcount++; - } - - make_env_renames(env, rcount, rstart, rstart_sec, 0, stx); - - env->rename_var_count = count; - env->rename_rstart = rstart; - if (count < env->num_bindings) { - /* save for next time around: */ - env->dup_check = ht; - } else { - /* drop a saved table if there; we're done with all increments */ - env->dup_check = NULL; - } - } - - if (SCHEME_STXP(stx)) { - for (l = env->renames; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - stx = scheme_add_rename(stx, SCHEME_CAR(l)); - } - if (!SCHEME_NULLP(l)) - stx = scheme_add_rename(stx, l); - } - } - } else if (env->flags & SCHEME_INTDEF_SHADOW) { - /* Just extract existing uids from identifiers, and don't need to - add renames to syntax objects. */ - if (!env->uids) { - Scheme_Object **uids, *uid; - int i; - - uids = MALLOC_N(Scheme_Object *, env->num_bindings); - env->uids = uids; - - for (i = env->num_bindings; i--; ) { - uid = scheme_stx_moduleless_env(env->values[i]); - if (SCHEME_FALSEP(uid)) - scheme_signal_error("intdef shadow binding is #f for %d/%s", - SCHEME_TYPE(env->values[i]), - scheme_write_to_string(SCHEME_STX_VAL(env->values[i]), - NULL)); - env->uids[i] = uid; - } - } - } - - env = env->next; - } - - return stx; -} - -void scheme_seal_env_renames(Scheme_Comp_Env *env) -{ - env->dup_check = NULL; -} - -/*********************************************************************/ - -void create_skip_table(Scheme_Comp_Env *start_frame) -{ - Scheme_Comp_Env *end_frame, *frame; - int depth, dj = 0, dp = 0, i; - Scheme_Hash_Table *table; - int stride = 0; - - depth = start_frame->skip_depth; - - /* Find frames to be covered by the skip table. - The theory here is the same as the `mapped' table - in Scheme_Cert (see stxobj.c) */ - for (end_frame = start_frame->next; - end_frame && ((depth & end_frame->skip_depth) != end_frame->skip_depth); - end_frame = end_frame->next) { - stride++; - } - - table = scheme_make_hash_table(SCHEME_hash_ptr); - - for (frame = start_frame; frame != end_frame; frame = frame->next) { - if (frame->flags & SCHEME_LAMBDA_FRAME) - dj++; - dp += frame->num_bindings; - for (i = frame->num_bindings; i--; ) { - if (frame->values[i]) { - scheme_hash_set(table, SCHEME_STX_VAL(frame->values[i]), scheme_true); - } - } - for (i = COMPILE_DATA(frame)->num_const; i--; ) { - scheme_hash_set(table, SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]), scheme_true); - } - } - - scheme_hash_set(table, scheme_make_integer(0), (Scheme_Object *)end_frame); - scheme_hash_set(table, scheme_make_integer(1), scheme_make_integer(dj)); - scheme_hash_set(table, scheme_make_integer(2), scheme_make_integer(dp)); - - start_frame->skip_table = table; -} - -/*********************************************************************/ -/* - - scheme_lookup_binding() is the main resolver of lexical, module, - and top-level bindings. Depending on the value of `flags', it can - return a value whose type tag is: - - scheme_macro_type (id was bound to syntax), - - scheme_macro_set_type (id was bound to a set!-transformer), - - scheme_macro_id_type (id was bound to a rename-transformer), - - scheme_local_type (id was lexical), - - scheme_variable_type (id is a global or module-bound variable), - or - - scheme_module_variable_type (id is a module-bound variable). - -*/ - -Scheme_Object * -scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, - Scheme_Object *certs, Scheme_Object *in_modidx, - Scheme_Env **_menv, int *_protected, - Scheme_Object **_lexical_binding_id) -{ - Scheme_Comp_Env *frame; - int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0; - Scheme_Bucket *b; - Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; - Scheme_Object *find_id_sym = NULL, *rename_insp = NULL; - Scheme_Env *genv; - intptr_t phase; - - /* Need to know the phase being compiled */ - phase = env->genv->phase; - - /* Walk through the compilation frames */ - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - Scheme_Object *uid; - - while (1) { - if (frame->skip_table) { - if (!scheme_hash_get(frame->skip_table, SCHEME_STX_VAL(find_id))) { - /* Skip ahead. 0 maps to frame, 1 maps to j delta, and 2 maps to p delta */ - val = scheme_hash_get(frame->skip_table, scheme_make_integer(1)); - j += (int)SCHEME_INT_VAL(val); - val = scheme_hash_get(frame->skip_table, scheme_make_integer(2)); - p += (int)SCHEME_INT_VAL(val); - frame = (Scheme_Comp_Env *)scheme_hash_get(frame->skip_table, scheme_make_integer(0)); - } else - break; - } else if (frame->skip_depth && !(frame->skip_depth & 0x1F)) { - /* We're some multiple of 32 frames deep. Build a skip table and try again. */ - create_skip_table(frame); - } else - break; - } - - if (frame->flags & SCHEME_LAMBDA_FRAME) - j++; - - if (!skip_stops || !(frame->flags & SCHEME_FOR_STOPS)) { - if (frame->flags & SCHEME_FOR_STOPS) - skip_stops = 1; - - uid = scheme_env_frame_uid(frame); - - if (!find_id_sym - && (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) - find_id_sym = scheme_stx_get_module_eq_sym(find_id, scheme_make_integer(phase)); - - for (i = frame->num_bindings; i--; ) { - if (frame->values[i]) { - if (frame->uids) - uid = frame->uids[i]; - if (SAME_OBJ(SCHEME_STX_VAL(find_id), SCHEME_STX_VAL(frame->values[i])) - && (scheme_stx_env_bound_eq(find_id, frame->values[i], uid, scheme_make_integer(phase)) - || ((frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME) - && scheme_stx_module_eq2(find_id, frame->values[i], scheme_make_integer(phase), find_id_sym)) - || ((frame->flags & SCHEME_CAPTURE_LIFTED) - && scheme_stx_bound_eq(find_id, frame->values[i], scheme_make_integer(phase))))) { - /* Found a lambda-, let-, etc. bound variable: */ - /* First, check certs (don't bind with fewer certs): */ - if (!(flags & SCHEME_NO_CERT_CHECKS) - && !(frame->flags & (SCHEME_CAPTURE_WITHOUT_RENAME | SCHEME_CAPTURE_LIFTED))) { - if (scheme_stx_has_more_certs(find_id, certs, frame->values[i], frame->certs)) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "reference is more certified than binding"); - return NULL; - } - } - /* Looks ok; return a lexical reference */ - if (_lexical_binding_id) { - if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) - val = scheme_stx_remove_extra_marks(find_id, frame->values[i], - ((frame->flags & SCHEME_CAPTURE_LIFTED) - ? NULL - : uid)); - else - val = find_id; - *_lexical_binding_id = val; - } - if (flags & SCHEME_DONT_MARK_USE) - return scheme_make_local(scheme_local_type, 0, 0); - else - return (Scheme_Object *)get_frame_loc(frame, i, j, p, flags); - } - } - } - - for (i = COMPILE_DATA(frame)->num_const; i--; ) { - int issame; - if (frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME) - issame = scheme_stx_module_eq2(find_id, COMPILE_DATA(frame)->const_names[i], - scheme_make_integer(phase), find_id_sym); - else { - if (COMPILE_DATA(frame)->const_uids) uid = COMPILE_DATA(frame)->const_uids[i]; - issame = (SAME_OBJ(SCHEME_STX_VAL(find_id), - SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i])) - && scheme_stx_env_bound_eq(find_id, COMPILE_DATA(frame)->const_names[i], uid, - scheme_make_integer(phase))); - } - - if (issame) { - if (!(flags & SCHEME_NO_CERT_CHECKS) - && !(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) { - if (scheme_stx_has_more_certs(find_id, certs, COMPILE_DATA(frame)->const_names[i], frame->certs)) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "reference is more certified than binding"); - return NULL; - } - } - - if (_lexical_binding_id) { - if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) - val = scheme_stx_remove_extra_marks(find_id, COMPILE_DATA(frame)->const_names[i], - ((frame->flags & SCHEME_CAPTURE_LIFTED) - ? NULL - : uid)); - else - val = find_id; - *_lexical_binding_id = val; - } - - val = COMPILE_DATA(frame)->const_vals[i]; - - if (!val) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); - return NULL; - } - - if (SCHEME_FALSEP(val)) { - /* Corresponds to a run-time binding (but will be replaced later - through a renaming to a different binding) */ - if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) - return scheme_make_local(scheme_local_type, 0, 0); - return NULL; - } - - if (!(flags & SCHEME_ENV_CONSTANTS_OK)) { - if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) - return val; - else - scheme_wrong_syntax(scheme_set_stx_string, NULL, find_id, - "local syntax identifier cannot be mutated"); - return NULL; - } - - return val; - } - } - } - - p += frame->num_bindings; - } - - src_find_id = find_id; - modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, - NULL, NULL, NULL, NULL, &rename_insp); - /* If modidx and modidx is not #, then find_id is now a - symbol, otherwise it's still an identifier. */ - - /* Used out of context? */ - if (SAME_OBJ(modidx, scheme_undefined)) { - if (SCHEME_STXP(find_id)) { - /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */ - find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); - if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id))) - modidx = NULL; /* yes, it is bound */ - } - - if (modidx) { - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); - } - if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) - return scheme_make_local(scheme_local_type, 0, 0); - return NULL; - } - } - - if (modidx) { - /* If it's an access path, resolve it: */ - modname = scheme_module_resolve(modidx, 1); - - if (env->genv->module && SAME_OBJ(modname, env->genv->module->modname)) { - modidx = NULL; - modname = NULL; - genv = env->genv; - /* So we can distinguish between unbound identifiers in a module - and references to top-level definitions: */ - module_self_reference = 1; - } else { - genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase)); - - if (!genv) { - if (env->genv->phase) { - /* The failure might be due a laziness in required-syntax - execution. Force all laziness at the prior level - and try again. */ - scheme_module_force_lazy(env->genv, 1); - genv = scheme_module_access(modname, env->genv, SCHEME_INT_VAL(mod_defn_phase)); - } - - if (!genv) { - scheme_wrong_syntax("require", NULL, src_find_id, - "namespace mismatch; reference (phase %d) to a module" - " %D that is not available (phase level %d)", - env->genv->phase, modname, SCHEME_INT_VAL(mod_defn_phase)); - return NULL; - } - } - } - } else { - genv = env->genv; - modname = NULL; - - if (genv->module && genv->disallow_unbound) { - /* Free identifier. Maybe don't continue. */ - if (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) { - scheme_wrong_syntax(((flags & SCHEME_SETTING) - ? scheme_set_stx_string - : scheme_var_ref_string), - NULL, src_find_id, "unbound identifier in module"); - return NULL; - } - if (flags & SCHEME_NULL_FOR_UNBOUND) - return NULL; - } - } - - if (_menv && genv->module) - *_menv = genv; - - if (!modname && SCHEME_STXP(find_id)) - find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); - else - find_global_id = find_id; - - /* Try syntax table: */ - if (modname) { - val = scheme_module_syntax(modname, env->genv, find_id); - if (val && !(flags & SCHEME_NO_CERT_CHECKS)) - scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, certs, NULL, rename_insp, - -2, 0, - NULL, NULL, - env->genv, NULL); - } else { - /* Only try syntax table if there's not an explicit (later) - variable mapping: */ - if (genv->shadowed_syntax - && scheme_hash_get(genv->shadowed_syntax, find_global_id)) - val = NULL; - else - val = scheme_lookup_in_table(genv->syntax, (const char *)find_global_id); - } - - if (val) { - return val; - } - - if (modname) { - Scheme_Object *pos; - if (flags & SCHEME_NO_CERT_CHECKS) - pos = 0; - else - pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, certs, NULL, rename_insp, -1, 1, - _protected, NULL, env->genv, NULL); - modpos = (int)SCHEME_INT_VAL(pos); - } else - modpos = -1; - - if (modname && (flags & SCHEME_SETTING)) { - if (SAME_OBJ(src_find_id, find_id) || SAME_OBJ(SCHEME_STX_SYM(src_find_id), find_id)) - find_id = NULL; - scheme_wrong_syntax(scheme_set_stx_string, find_id, src_find_id, "cannot mutate module-required identifier"); - return NULL; - } - - if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) - && (genv->module && genv->disallow_unbound)) { - /* Check for set! of unbound identifier: */ - if (!scheme_lookup_in_table(genv->toplevel, (const char *)find_global_id)) { - scheme_wrong_syntax(((flags & SCHEME_SETTING) - ? scheme_set_stx_string - : scheme_var_ref_string), - NULL, src_find_id, "unbound identifier in module"); - return NULL; - } - } - - if (!modname && (flags & SCHEME_NULL_FOR_UNBOUND)) { - if (module_self_reference) { - /* Since the module has a rename for this id, it's certainly defined. */ - if (!(flags & SCHEME_RESOLVE_MODIDS)) { - /* This is the same thing as #%top handling in compile mode. But - for expand mode, it prevents wrapping the identifier with #%top. */ - /* Don't need a pos, because the symbol's gensym-ness (if any) will be - preserved within the module. */ - return scheme_hash_module_variable(genv, genv->module->self_modidx, find_id, - genv->module->insp, - -1, genv->mod_phase); - } - } else - return NULL; - } - - /* Used to have `&& !SAME_OBJ(modidx, modname)' below, but that was a bad - idea, because it causes module instances to be preserved. */ - if (modname && !(flags & SCHEME_RESOLVE_MODIDS) - && (!(scheme_is_kernel_modname(modname) - || scheme_is_unsafe_modname(modname) - || scheme_is_flfxnum_modname(modname) - || scheme_is_futures_modname(modname)) - || (flags & SCHEME_REFERENCING))) { - /* Create a module variable reference, so that idx is preserved: */ - return scheme_hash_module_variable(env->genv, modidx, find_id, - genv->module->insp, - modpos, SCHEME_INT_VAL(mod_defn_phase)); - } - - if (!modname - && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) - && genv->module - && !(flags & SCHEME_RESOLVE_MODIDS)) { - /* Need to return a variable reference in this case, too. */ - return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, - genv->module->insp, - modpos, genv->mod_phase); - } - - b = scheme_bucket_from_table(genv->toplevel, (char *)find_global_id); - - if ((flags & SCHEME_ELIM_CONST) && b && b->val - && (((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_CONST) - && !(flags & SCHEME_GLOB_ALWAYS_REFERENCE) - && (!modname || scheme_is_kernel_modname(modname))) - return (Scheme_Object *)b->val; - - ASSERT_IS_VARIABLE_BUCKET(b); - scheme_set_bucket_home(b, genv); - - return (Scheme_Object *)b; -} - -int scheme_is_imported(Scheme_Object *var, Scheme_Comp_Env *env) -{ - 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)) - return 1; - } else - return 1; - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type)) { - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)var); - if (!SAME_OBJ(home, env->genv)) - return 1; - } else - return 1; - } - return 0; -} - -Scheme_Object *scheme_extract_unsafe(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_unsafe_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -Scheme_Object *scheme_extract_flfxnum(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_flfxnum_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -Scheme_Object *scheme_extract_futures(Scheme_Object *o) -{ - Scheme_Env *home; - home = scheme_get_bucket_home((Scheme_Bucket *)o); - if (home && home->module && scheme_is_futures_modname(home->module->modname)) - return (Scheme_Object *)((Scheme_Bucket *)o)->val; - else - return NULL; -} - -int scheme_env_check_reset_any_use(Scheme_Comp_Env *frame) -{ - int any_use; - - any_use = COMPILE_DATA(frame)->any_use; - COMPILE_DATA(frame)->any_use = 0; - - return any_use; -} - -int scheme_env_min_use_below(Scheme_Comp_Env *frame, int pos) -{ - return COMPILE_DATA(frame)->min_use < pos; -} - -int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count) -{ - int *v, i; - - v = MALLOC_N_ATOMIC(int, count); - memcpy(v, COMPILE_DATA(frame)->use + start, sizeof(int) * count); - - for (i = count; i--; ) { - int old; - old = v[i]; - v[i] = 0; - if (old & (ARBITRARY_USE | ONE_ARBITRARY_USE | CONSTRAINED_USE)) { - v[i] |= SCHEME_WAS_USED; - if (!(old & (ARBITRARY_USE | WAS_SET_BANGED))) { - if (old & ONE_ARBITRARY_USE) - v[i] |= SCHEME_WAS_APPLIED_EXCEPT_ONCE; - else - v[i] |= SCHEME_WAS_ONLY_APPLIED; - } - } - if (old & WAS_SET_BANGED) - v[i] |= SCHEME_WAS_SET_BANGED; - v[i] |= (old & SCHEME_USE_COUNT_MASK); - } - - return v; -} - -/*========================================================================*/ -/* syntax-checking utils */ -/*========================================================================*/ - -void scheme_check_identifier(const char *formname, Scheme_Object *id, - const char *where, Scheme_Comp_Env *env, - Scheme_Object *form) -{ - if (!where) - where = ""; - - if (!SCHEME_STX_SYMBOLP(id)) - scheme_wrong_syntax(formname, form ? id : NULL, - form ? form : id, - "not an identifier%s", where); -} - -void scheme_begin_dup_symbol_check(DupCheckRecord *r, Scheme_Comp_Env *env) -{ - r->phase = env->genv->phase; - r->count = 0; -} - -void scheme_dup_symbol_check(DupCheckRecord *r, const char *where, - Scheme_Object *symbol, char *what, - Scheme_Object *form) -{ - int i; - - if (r->count <= 5) { - for (i = 0; i < r->count; i++) { - if (scheme_stx_bound_eq(symbol, r->syms[i], scheme_make_integer(r->phase))) - scheme_wrong_syntax(where, symbol, form, - "duplicate %s name", what); - } - - if (r->count < 5) { - r->syms[r->count++] = symbol; - return; - } else { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_bound_id); - r->ht = ht; - for (i = 0; i < r->count; i++) { - scheme_hash_set(ht, r->syms[i], scheme_true); - } - r->count++; - } - } - - if (scheme_hash_get(r->ht, symbol)) { - scheme_wrong_syntax(where, symbol, form, - "duplicate %s name", what); - } - - scheme_hash_set(r->ht, symbol, scheme_true); -} - -/*========================================================================*/ -/* compile-time env for optimization */ -/*========================================================================*/ - -Optimize_Info *scheme_optimize_info_create() -{ - Optimize_Info *info; - - info = MALLOC_ONE_RT(Optimize_Info); -#ifdef MZTAG_REQUIRED - info->type = scheme_rt_optimize_info; -#endif - info->inline_fuel = 32; - - return info; -} - -static void register_transitive_use(Optimize_Info *info, int pos, int j); - -static void register_stat_dist(Optimize_Info *info, int i, int j) -{ - if (!info->stat_dists) { - int k, *ia; - char **ca; - ca = MALLOC_N(char*, info->new_frame); - info->stat_dists = ca; - ia = MALLOC_N_ATOMIC(int, info->new_frame); - info->sd_depths = ia; - for (k = info->new_frame; k--; ) { - info->sd_depths[k] = 0; - } - } - - if (i >= info->new_frame) - scheme_signal_error("internal error: bad stat-dist index"); - - if (info->sd_depths[i] <= j) { - char *naya, *a; - int k; - - naya = MALLOC_N_ATOMIC(char, (j + 1)); - for (k = j + 1; k--; ) { - naya[k] = 0; - } - a = info->stat_dists[i]; - for (k = info->sd_depths[i]; k--; ) { - naya[k] = a[k]; - } - - info->stat_dists[i] = naya; - info->sd_depths[i] = j + 1; - } - - if (info->transitive_use && info->transitive_use[i]) { - /* We're using a procedure that we weren't sure would be used. - Transitively mark everything that the procedure uses --- unless - a transitive accumulation is in effect, in which case we - don't follow this one now, leaving it to be triggered when - the one we're accumulating is triggered. */ - if (!info->transitive_use_pos) { - mzshort *map = info->transitive_use[i]; - int len = info->transitive_use_len[i]; - int k; - - info->transitive_use[i] = NULL; - - for (k = 0; k < len; k++) { - register_transitive_use(info, map[k], 0); - } - } - } - - info->stat_dists[i][j] = 1; -} - -static Scheme_Object *transitive_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Optimize_Info *info = (Optimize_Info *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - register_transitive_use(info, (int)p->ku.k.i1, (int)p->ku.k.i2); - - return scheme_false; -} - -static void register_transitive_use(Optimize_Info *info, int pos, int j) -{ -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)info; - p->ku.k.i1 = pos; - p->ku.k.i2 = j; - - scheme_handle_stack_overflow(transitive_k); - - return; - } -#endif - - while (info) { - if (info->flags & SCHEME_LAMBDA_FRAME) - j++; - if (pos < info->new_frame) - break; - pos -= info->new_frame; - info = info->next; - } - - if (info->sd_depths[pos] <= j) { - scheme_signal_error("bad transitive position depth: %d vs. %d", - info->sd_depths[pos], j); - } - - register_stat_dist(info, pos, j); -} - -void scheme_env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **_map) -{ - /* A closure map lists the captured variables for a closure; the - indices are resolved two new indices in the second phase of - compilation. */ - Optimize_Info *frame; - int i, j, pos = 0, lpos = 0, tu; - mzshort *map, size; - - /* Count vars used by this closure (skip args): */ - j = 1; - for (frame = info->next; frame; frame = frame->next) { - if (frame->flags & SCHEME_LAMBDA_FRAME) - j++; - - if (frame->stat_dists) { - for (i = 0; i < frame->new_frame; i++) { - if (frame->sd_depths[i] > j) { - if (frame->stat_dists[i][j]) { - pos++; - } - } - } - } - } - - size = pos; - *_size = size; - map = MALLOC_N_ATOMIC(mzshort, size); - *_map = map; - - if (info->next && info->next->transitive_use_pos) { - info->next->transitive_use[info->next->transitive_use_pos - 1] = map; - info->next->transitive_use_len[info->next->transitive_use_pos - 1] = size; - tu = 1; - } else - tu = 0; - - /* Build map, unmarking locals and marking deeper in parent frame */ - j = 1; pos = 0; - for (frame = info->next; frame; frame = frame->next) { - if (frame->flags & SCHEME_LAMBDA_FRAME) - j++; - - if (frame->stat_dists) { - for (i = 0; i < frame->new_frame; i++) { - if (frame->sd_depths[i] > j) { - if (frame->stat_dists[i][j]) { - map[pos++] = lpos; - frame->stat_dists[i][j] = 0; /* This closure's done with these vars... */ - if (!tu) - frame->stat_dists[i][j - 1] = 1; /* ... but ensure previous keeps */ - } - } - lpos++; - } - } else - lpos += frame->new_frame; - } -} - -int scheme_env_uses_toplevel(Optimize_Info *frame) -{ - int used; - - used = frame->used_toplevel; - - if (used) { - /* Propagate use to an enclosing lambda, if any: */ - frame = frame->next; - while (frame) { - if (frame->flags & SCHEME_LAMBDA_FRAME) { - frame->used_toplevel = 1; - break; - } - frame = frame->next; - } - } - - return used; -} - -void scheme_optimize_info_used_top(Optimize_Info *info) -{ - while (info) { - if (info->flags & SCHEME_LAMBDA_FRAME) { - info->used_toplevel = 1; - break; - } - info = info->next; - } -} - -void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use) -{ - /* A raw-pair `value' is an indicator for whether a letrec-bound - variable is ready. */ - Scheme_Object *p; - - p = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(p)[0] = info->consts; - SCHEME_VEC_ELS(p)[1] = scheme_make_integer(pos); - SCHEME_VEC_ELS(p)[2] = value; - SCHEME_VEC_ELS(p)[3] = (single_use ? scheme_true : scheme_false); - - info->consts = p; -} - -Scheme_Once_Used *scheme_make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev) -{ - Scheme_Once_Used *o; - - o = MALLOC_ONE_TAGGED(Scheme_Once_Used); - o->so.type = scheme_once_used_type; - - o->expr = val; - o->pos = pos; - o->vclock = vclock; - - if (prev) - prev->next = o; - - return o; -} - -static void register_use(Optimize_Info *info, int pos, int flag) -/* pos must be in immediate frame */ -{ - if (!info->use) { - char *use; - use = (char *)scheme_malloc_atomic(info->new_frame); - memset(use, 0, info->new_frame); - info->use = use; - } - info->use[pos] |= flag; -} - -void scheme_optimize_mutated(Optimize_Info *info, int pos) -/* pos must be in immediate frame */ -{ - register_use(info, pos, 0x1); -} - -void scheme_optimize_produces_flonum(Optimize_Info *info, int pos) -/* pos must be in immediate frame */ -{ - register_use(info, pos, 0x4); -} - -Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated) -/* pos is in new-frame counts, and we want to produce an old-frame reference if - it's not mutated */ -{ - int delta = 0; - - while (1) { - if (pos < info->new_frame) - break; - pos -= info->new_frame; - delta += info->original_frame; - info = info->next; - } - - if (unless_mutated) - if (info->use && (info->use[pos] & 0x1)) - return NULL; - - return scheme_make_local(scheme_local_type, pos + delta, 0); -} - -int scheme_optimize_is_used(Optimize_Info *info, int pos) -/* pos must be in immediate frame */ -{ - int i; - - if (info->stat_dists) { - for (i = info->sd_depths[pos]; i--; ) { - if (info->stat_dists[pos][i]) - return 1; - } - } - - return 0; -} - -static int check_use(Optimize_Info *info, int pos, int flag) -/* pos is in new-frame counts */ -{ - while (1) { - if (pos < info->new_frame) - break; - pos -= info->new_frame; - info = info->next; - } - - if (info->use && (info->use[pos] & flag)) - return 1; - - return 0; -} - -int scheme_optimize_is_mutated(Optimize_Info *info, int pos) -/* pos is in new-frame counts */ -{ - return check_use(info, pos, 0x1); -} - -int scheme_optimize_is_flonum_arg(Optimize_Info *info, int pos, int depth) -/* pos is in new-frame counts */ -{ - return check_use(info, pos, 0x2); -} - -int scheme_optimize_is_flonum_valued(Optimize_Info *info, int pos) -/* pos is in new-frame counts */ -{ - return check_use(info, pos, 0x4); -} - -int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos) -{ - int j, i; - - if (info->stat_dists) { - for (i = start_pos; i < end_pos; i++) { - for (j = info->sd_depths[i]; j--; ) { - if (info->stat_dists[i][j]) - return 1; - } - } - } - - if (info->transitive_use) { - for (i = info->new_frame; i--; ) { - if (info->transitive_use[i]) { - for (j = info->transitive_use_len[i]; j--; ) { - if ((info->transitive_use[i][j] >= start_pos) - && (info->transitive_use[i][j] < end_pos)) - return 1; - } - } - } - } - - return 0; -} - -static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, - int *not_ready, int once_used_ok, int context, int *potential_size, - int disrupt_single_use) -{ - Scheme_Object *p, *n; - int delta = 0; - - while (info) { - if (info->flags & SCHEME_LAMBDA_FRAME) - j++; - if (pos < info->original_frame) - break; - pos -= info->original_frame; - delta += info->new_frame; - info = info->next; - } - - if (context & OPT_CONTEXT_FLONUM_ARG) - register_use(info, pos, 0x2); - - p = info->consts; - while (p) { - n = SCHEME_VEC_ELS(p)[1]; - if (SCHEME_INT_VAL(n) == pos) { - n = SCHEME_VEC_ELS(p)[2]; - if (info->flags & SCHEME_POST_BIND_FRAME) - delta += info->new_frame; - if (SCHEME_RPAIRP(n)) { - /* This was a letrec-bound identifier that may or may not be ready, - but which wasn't replaced with more information. */ - if (not_ready) - *not_ready = SCHEME_TRUEP(SCHEME_CAR(n)); - break; - } - if (SCHEME_BOXP(n)) { - /* A potential-size record: */ - if (potential_size) - *potential_size = (int)SCHEME_INT_VAL(SCHEME_BOX_VAL(n)); - break; - } - if (single_use) - *single_use = SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]); - if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_unclosed_procedure_type)) { - if (!closure_offset) - break; - else - *closure_offset = delta; - } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_case_lambda_sequence_type)) { - if (!closure_offset) - break; - else - *closure_offset = delta; - } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) { - /* Ok */ - } else if (closure_offset) { - /* Inlining can deal procedures and top-levels, but not other things. */ - return NULL; - } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_once_used_type)) { - Scheme_Once_Used *o; - - if (disrupt_single_use) { - ((Scheme_Once_Used *)n)->expr = NULL; - ((Scheme_Once_Used *)n)->vclock = -1; - } - - if (!once_used_ok) - break; - - o = (Scheme_Once_Used *)n; - if (!o->expr) break; /* disrupted or not available */ - - o->delta = delta; - o->info = info; - return (Scheme_Object *)o; - } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) { - int pos; - - pos = SCHEME_LOCAL_POS(n); - if (info->flags & SCHEME_LAMBDA_FRAME) - j--; /* because it will get re-added on recur */ - else if (info->flags & SCHEME_POST_BIND_FRAME) - info = info->next; /* bindings are relative to next frame */ - - /* Marks local as used; we don't expect to get back - a value, because chaining would normally happen on the - propagate-call side. Chaining there also means that we - avoid stack overflow here. */ - if (single_use) { - if (!*single_use) - single_use = NULL; - } - - /* If the referenced variable is not single-use, then - the variable it is replaced by is no longer single-use */ - disrupt_single_use = !SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]); - - n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL, - once_used_ok && !disrupt_single_use, context, - potential_size, disrupt_single_use); - - if (!n) { - /* Return shifted reference to other local: */ - delta += scheme_optimize_info_get_shift(info, pos); - n = scheme_make_local(scheme_local_type, pos + delta, 0); - } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_once_used_type)) { - /* Need to adjust delta: */ - delta = scheme_optimize_info_get_shift(info, pos); - ((Scheme_Once_Used *)n)->delta += delta; - } - } - return n; - } - p = SCHEME_VEC_ELS(p)[0]; - } - - if (!closure_offset) - register_stat_dist(info, pos, j); - - return NULL; -} - -Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use, - int once_used_ok, int context, int *potential_size) -{ - return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok, context, potential_size, 0); -} - -int scheme_optimize_info_is_ready(Optimize_Info *info, int pos) -{ - int closure_offset, single_use, ready = 1; - - do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready, 0, 0, NULL, 0); - - return ready; -} - -Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags) -{ - Optimize_Info *naya; - - naya = scheme_optimize_info_create(); - naya->flags = (short)flags; - naya->next = info; - naya->original_frame = orig; - naya->new_frame = current; - naya->inline_fuel = info->inline_fuel; - naya->letrec_not_twice = info->letrec_not_twice; - naya->enforce_const = info->enforce_const; - naya->top_level_consts = info->top_level_consts; - naya->context = info->context; - naya->vclock = info->vclock; - naya->use_psize = info->use_psize; - - return naya; -} - -int scheme_optimize_info_get_shift(Optimize_Info *info, int pos) -{ - int delta = 0; - - while (info) { - if (pos < info->original_frame) - break; - pos -= info->original_frame; - delta += (info->new_frame - info->original_frame); - info = info->next; - } - - if (!info) - scheme_signal_error("error looking for local-variable offset"); - - return delta; -} - -void scheme_optimize_info_done(Optimize_Info *info) -{ - info->next->size += info->size; - info->next->psize += info->psize; - info->next->vclock = info->vclock; - if (info->has_nonleaf) - info->next->has_nonleaf = 1; -} - -/*========================================================================*/ -/* compile-time env for resolve */ -/*========================================================================*/ - -/* See eval.c for information about the compilation phases. */ - -Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify) -{ - Resolve_Prefix *rp; - Scheme_Object **tls, **stxes, *simplify_cache, *m; - Scheme_Hash_Table *ht; - int i; - - rp = MALLOC_ONE_TAGGED(Resolve_Prefix); - rp->so.type = scheme_resolve_prefix_type; - rp->num_toplevels = cp->num_toplevels; - rp->num_stxes = cp->num_stxes; - rp->uses_unsafe = cp->uses_unsafe; - - if (rp->num_toplevels) - tls = MALLOC_N(Scheme_Object*, rp->num_toplevels); - else - tls = NULL; - if (rp->num_stxes) - stxes = MALLOC_N(Scheme_Object*, rp->num_stxes); - else - stxes = NULL; - - rp->toplevels = tls; - rp->stxes = stxes; - - ht = cp->toplevels; - if (ht) { - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - m = ht->keys[i]; - if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_variable_type)) { - if (SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->base) - && SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->path)) { - /* Reduce self-referece to just a symbol: */ - m = ((Module_Variable *)m)->sym; - } - } - tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m; - } - } - } - - if (simplify) - simplify_cache = scheme_new_stx_simplify_cache(); - else - simplify_cache = NULL; - - ht = cp->stxes; - if (ht) { - for (i = 0; i < ht->size; i++) { - if (ht->vals[i]) { - scheme_simplify_stx(ht->keys[i], simplify_cache); - stxes[SCHEME_LOCAL_POS(ht->vals[i])] = ht->keys[i]; - } - } - } - - return rp; -} - -Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri) -{ - /* Rewrite stxes list based on actual uses at resolve pass. - If we have no lifts, we can just drop unused stxes. - Otherwise, if any stxes go unused, we just have to replace them - with NULL. */ - int i, cnt; - Scheme_Object **new_stxes, *v; - - if (!rp->num_stxes) - return rp; - - if (rp->num_lifts) - cnt = rp->num_stxes; - else - cnt = (int)ri->stx_map->count; - - new_stxes = MALLOC_N(Scheme_Object *, cnt); - - for (i = 0; i < rp->num_stxes; i++) { - if (ri->stx_map) - v = scheme_hash_get(ri->stx_map, scheme_make_integer(i)); - else - v = NULL; - if (v) { - new_stxes[SCHEME_INT_VAL(v)] = rp->stxes[i]; - } - } - - rp->stxes = new_stxes; - rp->num_stxes = cnt; - - return rp; -} - -Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp) -{ - Resolve_Info *naya; - Scheme_Object *b; - Scheme_Hash_Table *ht; - - naya = MALLOC_ONE_RT(Resolve_Info); -#ifdef MZTAG_REQUIRED - naya->type = scheme_rt_resolve_info; -#endif - naya->prefix = rp; - naya->count = 0; - naya->next = NULL; - naya->toplevel_pos = -1; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - naya->stx_map = ht; - - b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); - naya->use_jit = SCHEME_TRUEP(b); - - return naya; -} - -Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsize, int mapc) - /* size = number of appended items in run-time frame */ - /* oldisze = number of appended items in original compile-time frame */ - /* mapc = mappings that will be installed */ -{ - Resolve_Info *naya; - - naya = MALLOC_ONE_RT(Resolve_Info); -#ifdef MZTAG_REQUIRED - naya->type = scheme_rt_resolve_info; -#endif - naya->prefix = info->prefix; - naya->stx_map = info->stx_map; - naya->next = info; - naya->use_jit = info->use_jit; - naya->enforce_const = info->enforce_const; - naya->size = size; - naya->oldsize = oldsize; - naya->count = mapc; - naya->pos = 0; - naya->toplevel_pos = -1; - naya->lifts = info->lifts; - - if (mapc) { - int i, *ia; - mzshort *sa; - - sa = MALLOC_N_ATOMIC(mzshort, mapc); - naya->old_pos = sa; - sa = MALLOC_N_ATOMIC(mzshort, mapc); - naya->new_pos = sa; - ia = MALLOC_N_ATOMIC(int, mapc); - naya->flags = ia; - - for (i = mapc; i--; ) { - naya->old_pos[i] = 0; - naya->new_pos[i] = 0; - naya->flags[i] = 0; - } - } - - return naya; -} - -static void *ensure_tl_map_len(void *old_tl_map, int new_len) -{ - int current_len; - void *tl_map; - - if (!old_tl_map) - current_len = 0; - else if ((uintptr_t)old_tl_map & 0x1) - current_len = 31; - else - current_len = (*(int *)old_tl_map) * 32; - - if (new_len > current_len) { - /* allocate/grow tl_map */ - if (new_len <= 31) - tl_map = (void *)0x1; - else { - int len = ((new_len + 31) / 32); - tl_map = scheme_malloc_atomic((len + 1) * sizeof(int)); - memset(tl_map, 0, (len + 1) * sizeof(int)); - *(int *)tl_map = len; - } - - if (old_tl_map) { - if ((uintptr_t)old_tl_map & 0x1) { - ((int *)tl_map)[1] = ((uintptr_t)old_tl_map >> 1) & 0x7FFFFFFF; - } else { - memcpy((int *)tl_map + 1, - (int *)old_tl_map + 1, - sizeof(int) * (current_len / 32)); - } - } - - return tl_map; - } else - return old_tl_map; -} - -static void set_tl_pos_used(Resolve_Info *info, int pos) -{ - int tl_pos; - void *tl_map; - - /* Fixnum-like bit packing avoids allocation in the common case of a - small prefix. We use 31 fixnum-like bits (even on a 64-bit - platform, and even though fixnums are only 30 bits). */ - - if (pos >= info->prefix->num_toplevels) - tl_pos = pos - (info->prefix->num_stxes - ? (info->prefix->num_stxes + 1) - : 0); - else - tl_pos = pos; - - tl_map = ensure_tl_map_len(info->tl_map, tl_pos + 1); - info->tl_map = tl_map; - - if ((uintptr_t)info->tl_map & 0x1) - info->tl_map = (void *)((uintptr_t)tl_map | ((uintptr_t)1 << (tl_pos + 1))); - else - ((int *)tl_map)[1 + (tl_pos / 32)] |= (1 << (tl_pos & 31)); -} - -void *scheme_merge_tl_map(void *tl_map, void *new_tl_map) -{ - if (!tl_map) - return new_tl_map; - else if (!new_tl_map) - return tl_map; - else if (((uintptr_t)new_tl_map) & 0x1) { - if (((uintptr_t)tl_map) & 0x1) { - return (void *)((uintptr_t)tl_map | (uintptr_t)new_tl_map); - } else { - ((int *)tl_map)[1] |= ((uintptr_t)new_tl_map >> 1) & 0x7FFFFFFF; - return tl_map; - } - } else { - int i, len = *(int *)new_tl_map; - tl_map = ensure_tl_map_len(tl_map, len * 32); - for (i = 0; i < len; i++) { - ((int *)tl_map)[1+i] |= ((int *)new_tl_map)[1+i]; - } - return tl_map; - } -} - -void scheme_merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info) -{ - if (!new_info->tl_map) { - /* nothing to do */ - } else { - void *tl_map; - tl_map = scheme_merge_tl_map(info->tl_map, new_info->tl_map); - info->tl_map = tl_map; - } -} - -void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted) -{ - if (info->pos == info->count) { - scheme_signal_error("internal error: add_mapping: " - "too many: %d", info->pos); - } - - info->old_pos[info->pos] = oldp; - info->new_pos[info->pos] = newp; - info->flags[info->pos] = flags; - if (lifted) { - if (!info->lifted) { - Scheme_Object **lifteds; - lifteds = MALLOC_N(Scheme_Object*, info->count); - info->lifted = lifteds; - } - info->lifted[info->pos] = lifted; - } - - info->pos++; -} - -void scheme_resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted) -{ - int i; - - for (i = info->pos; i--; ) { - if (info->old_pos[i] == oldp) { - info->new_pos[i] = newp; - info->flags[i] = flags; - if (lifted) { - info->lifted[i] = lifted; - } - return; - } - } - - scheme_signal_error("internal error: adjust_mapping: " - "couldn't find: %d", oldp); -} - -void scheme_resolve_info_set_toplevel_pos(Resolve_Info *info, int pos) -{ - info->toplevel_pos = pos; -} - -static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **_lifted, int convert_shift) -{ - Resolve_Info *orig_info = info; - int i, offset = 0, orig = pos; - - if (_lifted) - *_lifted = NULL; - - while (info) { - for (i = info->pos; i--; ) { - int oldp = info->old_pos[i]; - if (pos == oldp) { - if (flags) - *flags = info->flags[i]; - if (info->lifted && (info->lifted[i])) { - int skip, shifted; - Scheme_Object *lifted, *tl, **ca; - - if (!_lifted) - scheme_signal_error("unexpected lifted binding"); - - lifted = info->lifted[i]; - - if (SCHEME_RPAIRP(lifted)) { - tl = SCHEME_CAR(lifted); - ca = (Scheme_Object **)SCHEME_CDR(lifted); - if (convert_shift) - shifted = (int)SCHEME_INT_VAL(ca[0]) + convert_shift - 1; - else - shifted = 0; - } else { - tl = lifted; - shifted = 0; - ca = NULL; - } - - if (SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type)) { - skip = scheme_resolve_toplevel_pos(orig_info); - tl = make_toplevel(skip + shifted, - SCHEME_TOPLEVEL_POS(tl), - 1, - SCHEME_TOPLEVEL_CONST); - - /* register if non-stub: */ - if (SCHEME_TOPLEVEL_POS(tl) >= (info->prefix->num_toplevels - + info->prefix->num_stxes - + (info->prefix->num_stxes - ? 1 - : 0))) - set_tl_pos_used(orig_info, SCHEME_TOPLEVEL_POS(tl)); - } - - if (SCHEME_RPAIRP(lifted)) { - int sz, i; - mzshort *posmap, *boxmap; - Scheme_Object *vec, *loc; - sz = (int)SCHEME_INT_VAL(ca[0]); - posmap = (mzshort *)ca[1]; - boxmap = (mzshort *)ca[3]; - vec = scheme_make_vector(sz + 1, NULL); - for (i = 0; i < sz; i++) { - int boxed = 0, flonumed = 0, flags = 0; - - if (boxmap) { - int byte = boxmap[(2 * i) / BITS_PER_MZSHORT]; - if (byte & ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) - boxed = 1; - if (byte & ((mzshort)2 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) { - flonumed = 1; - flags = SCHEME_LOCAL_FLONUM; - } - } - - loc = scheme_make_local(scheme_local_type, - posmap[i] + offset + shifted, - flags); - - if (boxed) - loc = scheme_box(loc); - else if (flonumed) - loc = scheme_make_vector(1, loc); - - SCHEME_VEC_ELS(vec)[i+1] = loc; - } - SCHEME_VEC_ELS(vec)[0] = ca[2]; - lifted = scheme_make_raw_pair(tl, vec); - } else - lifted = tl; - - *_lifted = lifted; - - return 0; - } else { - pos = info->new_pos[i]; - if (pos < 0) - scheme_signal_error("internal error: skipped binding is used"); - return pos + offset; - } - } - } - - if (info->in_proc) { - scheme_signal_error("internal error: scheme_resolve_info_lookup: " - "searching past procedure"); - } - - pos -= info->oldsize; - offset += info->size; - info = info->next; - } - - scheme_signal_error("internal error: scheme_resolve_info_lookup: " - "variable %d not found", orig); - - return 0; -} - -Scheme_Object *scheme_resolve_generate_stub_lift() -{ - return make_toplevel(0, 0, 1, SCHEME_TOPLEVEL_CONST); -} - -int scheme_resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted) -{ - int flags; - - resolve_info_lookup(info, pos, &flags, lifted, 0); - - return flags; -} - -int scheme_resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **lifted, int convert_shift) -{ - return resolve_info_lookup(info, pos, flags, lifted, convert_shift); -} - -int scheme_resolve_toplevel_pos(Resolve_Info *info) -{ - int pos = 0; - - while (info && (info->toplevel_pos < 0)) { - if (info->in_proc) { - scheme_signal_error("internal error: scheme_resolve_toplevel_pos: " - "searching past procedure"); - } - pos += info->size; - info = info->next; - } - - if (!info) - return pos; - else - return info->toplevel_pos + pos; -} - -int scheme_resolve_is_toplevel_available(Resolve_Info *info) -{ - while (info) { - if (info->toplevel_pos >= 0) - return 1; - if (info->in_proc) - return 0; - info = info->next; - } - - return 0; -} - -int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info) -{ - Scheme_Hash_Table *ht; - Scheme_Object *v; - - ht = info->stx_map; - - v = scheme_hash_get(ht, scheme_make_integer(i)); - if (!v) { - v = scheme_make_integer(ht->count); - scheme_hash_set(ht, scheme_make_integer(i), v); - } - - return (int)SCHEME_INT_VAL(v); -} - -int scheme_resolve_quote_syntax_pos(Resolve_Info *info) -{ - return info->prefix->num_toplevels; -} - -Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready) -{ - int skip, pos; - - skip = scheme_resolve_toplevel_pos(info); - - pos = SCHEME_TOPLEVEL_POS(expr); - - set_tl_pos_used(info, pos); - - return make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */ - pos, - 1, - SCHEME_TOPLEVEL_FLAGS(expr) & (SCHEME_TOPLEVEL_CONST - | (keep_ready - ? SCHEME_TOPLEVEL_READY - : 0))); -} - -Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta) -{ - return make_toplevel(SCHEME_TOPLEVEL_DEPTH(expr) + delta, - SCHEME_TOPLEVEL_POS(expr), - 1, - SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK); -} - -Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info) -{ - int skip, pos; - Scheme_Object *count; - - skip = scheme_resolve_toplevel_pos(info); - - count = SCHEME_VEC_ELS(info->lifts)[1]; - pos = (int)(SCHEME_INT_VAL(count) - + info->prefix->num_toplevels - + info->prefix->num_stxes - + (info->prefix->num_stxes ? 1 : 0)); - count = scheme_make_integer(SCHEME_INT_VAL(count) + 1); - SCHEME_VEC_ELS(info->lifts)[1] = count; - - set_tl_pos_used(info, pos); - - return make_toplevel(skip, - pos, - 1, - SCHEME_TOPLEVEL_CONST); -} - -Scheme_Object *scheme_resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl) -{ - return make_toplevel(0, - SCHEME_TOPLEVEL_POS(tl), - 1, - SCHEME_TOPLEVEL_CONST); -} - -int scheme_resolving_in_procedure(Resolve_Info *info) -{ - while (info) { - if (info->in_proc) - return 1; - info = info->next; - } - return 0; -} - -/*========================================================================*/ -/* run-time "stack" */ -/*========================================================================*/ - -Scheme_Object *scheme_make_envunbox(Scheme_Object *value) -{ - Scheme_Object *obj; - - obj = (Scheme_Object *)scheme_malloc_envunbox(sizeof(Scheme_Object*)); - SCHEME_ENVBOX_VAL(obj) = value; - - return obj; -} - /*========================================================================*/ /* run-time and expansion-time Scheme interface */ /*========================================================================*/ @@ -4559,30 +1474,8 @@ namespace_variable_value(int argc, Scheme_Object *argv[]) if (!use_map) v = scheme_lookup_global(argv[0], genv); - else { - Scheme_Full_Comp_Env inlined_e; - - scheme_prepare_env_renames(genv, mzMOD_RENAME_TOPLEVEL); - scheme_prepare_compile_env(genv); - - id = scheme_make_renamed_stx(argv[0], genv->rename_set); - - inlined_e.base.num_bindings = 0; - inlined_e.base.next = NULL; - inlined_e.base.genv = genv; - inlined_e.base.flags = SCHEME_TOPLEVEL_FRAME; - init_compile_data((Scheme_Comp_Env *)&inlined_e); - inlined_e.base.prefix = NULL; - - v = scheme_lookup_binding(id, (Scheme_Comp_Env *)&inlined_e, SCHEME_RESOLVE_MODIDS, NULL, NULL, NULL, NULL, NULL); - if (v) { - if (!SAME_TYPE(SCHEME_TYPE(v), scheme_variable_type)) { - use_map = -1; - v = NULL; - } else - v = (Scheme_Object *)(SCHEME_VAR_BUCKET(v))->val; - } - } + else + v = scheme_namespace_lookup_value(argv[0], genv, &id, &use_map); if (!v) { if ((argc > 2) && SCHEME_TRUEP(argv[2])) @@ -5159,8 +2052,8 @@ local_module_introduce(int argc, Scheme_Object *argv[]) static Scheme_Object * local_get_shadower(int argc, Scheme_Object *argv[]) { - Scheme_Comp_Env *env, *frame; - Scheme_Object *sym, *esym, *sym_marks = NULL, *orig_sym, *uid = NULL, *env_marks, *prop; + Scheme_Comp_Env *env; + Scheme_Object *sym, *sym_marks = NULL, *orig_sym, *uid = NULL; env = scheme_current_thread->current_local_env; if (!env) @@ -5175,60 +2068,7 @@ local_get_shadower(int argc, Scheme_Object *argv[]) sym_marks = scheme_stx_extract_marks(sym); - /* Walk backward through the frames, looking for a renaming binding - with the same marks as the given identifier, sym. Skip over - unsealed ribs, though. When we find a match, rename the given - identifier so that it matches frame. */ - for (frame = env; frame->next != NULL; frame = frame->next) { - int i; - - for (i = frame->num_bindings; i--; ) { - if (frame->values[i]) { - if (SAME_OBJ(SCHEME_STX_VAL(sym), SCHEME_STX_VAL(frame->values[i]))) { - prop = scheme_stx_property(frame->values[i], unshadowable_symbol, NULL); - if (SCHEME_FALSEP(prop)) { - esym = frame->values[i]; - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { - sym = esym; - if (frame->uids) - uid = frame->uids[i]; - else - uid = frame->uid; - break; - } - } - } - } - } - if (uid) - break; - - if (!COMPILE_DATA(frame)->sealed || *COMPILE_DATA(frame)->sealed) { - for (i = COMPILE_DATA(frame)->num_const; i--; ) { - if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) { - if (SAME_OBJ(SCHEME_STX_VAL(sym), - SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) { - esym = COMPILE_DATA(frame)->const_names[i]; - prop = scheme_stx_property(esym, unshadowable_symbol, NULL); - if (SCHEME_FALSEP(prop)) { - env_marks = scheme_stx_extract_marks(esym); - if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */ - sym = esym; - if (COMPILE_DATA(frame)->const_uids) - uid = COMPILE_DATA(frame)->const_uids[i]; - else - uid = frame->uid; - break; - } - } - } - } - } - } - if (uid) - break; - } + uid = scheme_find_local_shadower(sym, sym_marks, env); if (!uid) { /* No lexical shadower, but strip module context, if any */ @@ -5529,118 +2369,18 @@ local_module_expanding_provides(int argc, Scheme_Object *argv[]) return scheme_false; } -static Scheme_Object * -do_local_lift_expr(const char *who, int stx_pos, int argc, Scheme_Object *argv[]) -{ - Scheme_Env *menv; - Scheme_Comp_Env *env, *orig_env; - Scheme_Object *id, *ids, *rev_ids, *local_mark, *expr, *data, *vec, *id_sym; - Scheme_Lift_Capture_Proc cp; - Scheme_Object *orig_expr; - int count; - char buf[24]; - - if (stx_pos) { - if (SCHEME_INTP(argv[0])) { - count = (int)SCHEME_INT_VAL(argv[0]); - } else if (SCHEME_BIGNUMP(argv[0])) { - if (SCHEME_BIGPOS(argv[0])) - scheme_raise_out_of_memory(NULL, NULL); - count = -1; - } else - count = -1; - - if (count < 0) - scheme_wrong_type(who, "exact nonnegative integer", 0, argc, argv); - } else - count = 1; - - expr = argv[stx_pos]; - if (!SCHEME_STXP(expr)) - scheme_wrong_type(who, "syntax", stx_pos, argc, argv); - - env = orig_env = scheme_current_thread->current_local_env; - local_mark = scheme_current_thread->current_local_mark; - - if (!env) - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "%s: not currently transforming", - who); - - while (env && !COMPILE_DATA(env)->lifts) { - env = env->next; - } - - if (env) - if (SCHEME_FALSEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[0])) - env = NULL; - - if (!env) - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "syntax-local-lift-expression: no lift target"); - - expr = scheme_add_remove_mark(expr, local_mark); - - /* We don't really need a new symbol each time, since the mark - will generate new bindings. But lots of things work better or faster - when different bindings have different symbols. Use env->genv->id_counter - to help keep name generation deterministic within a module. */ - rev_ids = scheme_null; - while (count--) { - sprintf(buf, "lifted.%d", env->genv->id_counter++); - id_sym = scheme_intern_exact_parallel_symbol(buf, strlen(buf)); - - id = scheme_datum_to_syntax(id_sym, scheme_false, scheme_false, 0, 0); - id = scheme_add_remove_mark(id, scheme_new_mark()); - - rev_ids = scheme_make_pair(id, rev_ids); - } - ids = scheme_reverse(rev_ids); - - vec = COMPILE_DATA(env)->lifts; - cp = *(Scheme_Lift_Capture_Proc *)SCHEME_VEC_ELS(vec)[1]; - data = SCHEME_VEC_ELS(vec)[2]; - - menv = scheme_current_thread->current_local_menv; - - expr = scheme_stx_cert(expr, scheme_false, - (menv && menv->module) ? menv : NULL, - scheme_current_thread->current_local_certs, - NULL, 1); - - expr = scheme_stx_activate_certs(expr); - orig_expr = expr; - - expr = cp(data, &ids, expr, orig_env); - - expr = scheme_make_pair(expr, SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = expr; - - SCHEME_EXPAND_OBSERVE_LOCAL_LIFT(scheme_get_expand_observe(), ids, orig_expr); - - rev_ids = scheme_null; - for (; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - id = scheme_add_remove_mark(id, local_mark); - rev_ids = scheme_make_pair(id, rev_ids); - } - ids = scheme_reverse(rev_ids); - - return ids; -} - static Scheme_Object * local_lift_expr(int argc, Scheme_Object *argv[]) { Scheme_Object *ids; - ids = do_local_lift_expr("syntax-local-lift-expression", 0, argc, argv); + ids = scheme_do_local_lift_expr("syntax-local-lift-expression", 0, argc, argv); return SCHEME_CAR(ids); } static Scheme_Object * local_lift_exprs(int argc, Scheme_Object *argv[]) { - return do_local_lift_expr("syntax-local-lift-values-expression", 1, argc, argv); + return scheme_do_local_lift_expr("syntax-local-lift-values-expression", 1, argc, argv); } static Scheme_Object * @@ -5654,22 +2394,14 @@ local_lift_context(int argc, Scheme_Object *argv[]) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-lift-context: not currently transforming"); - while (env && !COMPILE_DATA(env)->lifts) { - env = env->next; - } - - if (!env) - return scheme_false; - - return SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[4]; + return scheme_local_lift_context(env); } static Scheme_Object * local_lift_end_statement(int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env; - Scheme_Object *local_mark, *expr, *pr; - Scheme_Object *orig_expr; + Scheme_Object *local_mark, *expr; expr = argv[0]; if (!SCHEME_STXP(expr)) @@ -5682,34 +2414,13 @@ local_lift_end_statement(int argc, Scheme_Object *argv[]) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-lift-module-end-declaration: not currently transforming"); - while (env) { - if ((COMPILE_DATA(env)->lifts) - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3])) - break; - env = env->next; - } - - if (!env) - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "syntax-local-lift-module-end-declaration: not currently transforming" - " a run-time expression in a module declaration"); - - expr = scheme_add_remove_mark(expr, local_mark); - orig_expr = expr; - - pr = scheme_make_pair(expr, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3]); - SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[3] = pr; - - SCHEME_EXPAND_OBSERVE_LIFT_STATEMENT(scheme_get_expand_observe(), orig_expr); - - return scheme_void; + return scheme_local_lift_end_statement(expr, local_mark, env); } static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env; - Scheme_Object *local_mark, *mark, *data, *pr, *form; - Scheme_Object *orig_form, *req_form; + Scheme_Object *local_mark; intptr_t phase; if (!SCHEME_STXP(argv[1])) @@ -5723,53 +2434,13 @@ static Scheme_Object *local_lift_require(int argc, Scheme_Object *argv[]) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-lift-require: not currently transforming"); - data = NULL; - - while (env) { - if (COMPILE_DATA(env)->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5])) { - data = SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[5]; - if (SCHEME_RPAIRP(data) - && !SCHEME_CAR(data)) { - env = (Scheme_Comp_Env *)SCHEME_CDR(data); - } else - break; - } else - env = env->next; - } - - if (!env) - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "syntax-local-lift-requires: could not find target context"); - - - mark = scheme_new_mark(); - - if (SCHEME_RPAIRP(data)) - form = scheme_parse_lifted_require(argv[0], phase, mark, SCHEME_CAR(data)); - else - form = scheme_toplevel_require_for_expand(argv[0], phase, env, mark); - - pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6]); - SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[6] = pr; - - req_form = form; - orig_form = argv[1]; - - form = orig_form; - form = scheme_add_remove_mark(form, local_mark); - form = scheme_add_remove_mark(form, mark); - form = scheme_add_remove_mark(form, local_mark); - - SCHEME_EXPAND_OBSERVE_LIFT_REQUIRE(scheme_get_expand_observe(), req_form, orig_form, form); - - return form; + return scheme_local_lift_require(argv[0], argv[1], phase, local_mark, env); } static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]) { Scheme_Comp_Env *env; - Scheme_Object *pr, *form, *local_mark; + Scheme_Object *form, *local_mark; form = argv[0]; if (!SCHEME_STXP(form)) @@ -5782,31 +2453,7 @@ static Scheme_Object *local_lift_provide(int argc, Scheme_Object *argv[]) scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-lift-provide: not currently transforming"); - while (env) { - if (COMPILE_DATA(env)->lifts - && SCHEME_TRUEP(SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7])) { - break; - } else - env = env->next; - } - - if (!env) - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "syntax-local-lift-provide: not expanding in a module run-time body"); - - form = scheme_add_remove_mark(form, local_mark); - form = scheme_datum_to_syntax(scheme_make_pair(scheme_datum_to_syntax(scheme_intern_symbol("#%provide"), - scheme_false, scheme_sys_wraps(env), - 0, 0), - scheme_make_pair(form, scheme_null)), - form, scheme_false, 0, 0); - - SCHEME_EXPAND_OBSERVE_LIFT_PROVIDE(scheme_get_expand_observe(), form); - - pr = scheme_make_pair(form, SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7]); - SCHEME_VEC_ELS(COMPILE_DATA(env)->lifts)[7] = pr; - - return scheme_void; + return scheme_local_lift_provide(form, local_mark, env); } static Scheme_Object * @@ -5876,237 +2523,6 @@ rename_transformer_p(int argc, Scheme_Object *argv[]) : scheme_false); } - -/*========================================================================*/ -/* [un]marshalling variable reference */ -/*========================================================================*/ - -static Scheme_Object *write_toplevel(Scheme_Object *obj) -{ - int pos, flags; - Scheme_Object *pr; - - pos = SCHEME_TOPLEVEL_POS(obj); - flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK); - - pr = (flags - ? scheme_make_pair(scheme_make_integer(pos), - scheme_make_integer(flags)) - : scheme_make_integer(pos)); - - return scheme_make_pair(scheme_make_integer(SCHEME_TOPLEVEL_DEPTH(obj)), - pr); -} - -static Scheme_Object *read_toplevel(Scheme_Object *obj) -{ - int pos, depth, flags; - - if (!SCHEME_PAIRP(obj)) return NULL; - - depth = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (SCHEME_PAIRP(obj)) { - pos = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - flags = SCHEME_INT_VAL(SCHEME_CDR(obj)) & SCHEME_TOPLEVEL_FLAGS_MASK; - } else { - pos = (int)SCHEME_INT_VAL(obj); - flags = 0; - } - - return make_toplevel(depth, pos, 1, flags); -} - -static Scheme_Object *write_variable(Scheme_Object *obj) - /* #%kernel references are handled in print.c, instead */ -{ - Scheme_Object *sym; - Scheme_Env *home; - Scheme_Module *m; - - sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key; - - home = scheme_get_bucket_home((Scheme_Bucket *)obj); - m = home->module; - - /* If we get a writeable variable (instead of a module variable), - it must be a reference to a module referenced directly by its - a symbolic name (i.e., no path). */ - - if (m) { - sym = scheme_make_pair(m->modname, sym); - if (home->mod_phase) - sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym); - } - - return sym; -} - -static Scheme_Object *read_variable(Scheme_Object *obj) - /* #%kernel references are handled in read.c, instead */ -{ - Scheme_Env *env; - - env = scheme_get_env(NULL); - - if (!SCHEME_SYMBOLP(obj)) return NULL; - - return (Scheme_Object *)scheme_global_bucket(obj, env); -} - -static Scheme_Object *write_module_variable(Scheme_Object *obj) -{ - scheme_signal_error("module variables should have been handled in print.c"); - return NULL; -} - -static Scheme_Object *read_module_variable(Scheme_Object *obj) -{ - scheme_signal_error("module variables should have been handled in read.c"); - return NULL; -} - -static Scheme_Object *write_local(Scheme_Object *obj) -{ - return scheme_make_integer(SCHEME_LOCAL_POS(obj)); -} - -static Scheme_Object *do_read_local(Scheme_Type t, Scheme_Object *obj) -{ - int n, flags; - - if (SCHEME_PAIRP(obj)) { - flags = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - } else - flags = 0; - - n = (int)SCHEME_INT_VAL(obj); - - return scheme_make_local(t, n, flags); -} - -static Scheme_Object *read_local(Scheme_Object *obj) -{ - return do_read_local(scheme_local_type, obj); -} - -static Scheme_Object *read_local_unbox(Scheme_Object *obj) -{ - return do_read_local(scheme_local_unbox_type, obj); -} - -static Scheme_Object *write_resolve_prefix(Scheme_Object *obj) -{ - Resolve_Prefix *rp = (Resolve_Prefix *)obj; - Scheme_Object *tv, *sv, *ds; - int i; - - i = rp->num_toplevels; - tv = scheme_make_vector(i, NULL); - while (i--) { - SCHEME_VEC_ELS(tv)[i] = rp->toplevels[i]; - } - - i = rp->num_stxes; - sv = scheme_make_vector(i, NULL); - while (i--) { - if (rp->stxes[i]) { - if (SCHEME_INTP(rp->stxes[i])) { - /* Need to foce this object, so we can write it. - This should only happen if we're writing back - code loaded from bytecode. */ - scheme_load_delayed_syntax(rp, i); - } - - ds = scheme_alloc_small_object(); - ds->type = scheme_delay_syntax_type; - SCHEME_PTR_VAL(ds) = rp->stxes[i]; - } else - ds = scheme_false; - SCHEME_VEC_ELS(sv)[i] = ds; - } - - tv = scheme_make_pair(scheme_make_integer(rp->num_lifts), - scheme_make_pair(tv, sv)); - - if (rp->uses_unsafe) - tv = scheme_make_pair(scheme_true, tv); - - return tv; -} - -static Scheme_Object *read_resolve_prefix(Scheme_Object *obj, Scheme_Object *insp) -{ - Resolve_Prefix *rp; - Scheme_Object *tv, *sv, **a, *stx; - intptr_t i; - int uses_unsafe = 0; - - if (!SCHEME_PAIRP(obj)) return NULL; - - if (!SCHEME_INTP(SCHEME_CAR(obj))) { - uses_unsafe = 1; - obj = SCHEME_CDR(obj); - } - - if (!SCHEME_PAIRP(obj)) return NULL; - - i = SCHEME_INT_VAL(SCHEME_CAR(obj)); - if (i < 0) return NULL; - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - tv = SCHEME_CAR(obj); - sv = SCHEME_CDR(obj); - - if (!SCHEME_VECTORP(tv)) return NULL; - if (!SCHEME_VECTORP(sv)) return NULL; - - rp = MALLOC_ONE_TAGGED(Resolve_Prefix); - rp->so.type = scheme_resolve_prefix_type; - rp->num_toplevels = (int)SCHEME_VEC_SIZE(tv); - rp->num_stxes = (int)SCHEME_VEC_SIZE(sv); - rp->num_lifts = (int)i; - if (uses_unsafe) - rp->uses_unsafe = insp; - - i = rp->num_toplevels; - a = MALLOC_N(Scheme_Object *, i); - while (i--) { - a[i] = SCHEME_VEC_ELS(tv)[i]; - } - rp->toplevels = a; - - i = rp->num_stxes; - a = MALLOC_N(Scheme_Object *, i); - while (i--) { - stx = SCHEME_VEC_ELS(sv)[i]; - if (SCHEME_FALSEP(stx)) { - stx = NULL; - } else if (SCHEME_RPAIRP(stx)) { - struct Scheme_Load_Delay *d; - Scheme_Object *pr; - d = (struct Scheme_Load_Delay *)SCHEME_CDR(stx); - stx = SCHEME_CAR(stx); - pr = rp->delay_info_rpair; - if (!pr) { - pr = scheme_make_raw_pair(scheme_make_integer(0), (Scheme_Object *)d); - rp->delay_info_rpair = pr; - } - SCHEME_CAR(pr) = scheme_make_integer(SCHEME_INT_VAL(SCHEME_CAR(pr)) + 1); - } else { - if (!SCHEME_STXP(stx)) return NULL; - } - a[i] = stx; - } - rp->stxes = a; - - return (Scheme_Object *)rp; -} - /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ @@ -6120,11 +2536,7 @@ START_XFORM_SKIP; static void register_traversers(void) { - GC_REG_TRAV(scheme_rt_comp_env, mark_comp_env); - GC_REG_TRAV(scheme_rt_resolve_info, mark_resolve_info); - GC_REG_TRAV(scheme_rt_optimize_info, mark_optimize_info); - GC_REG_TRAV(scheme_rt_sfs_info, mark_sfs_info); - GC_REG_TRAV(scheme_once_used_type, mark_once_used); + } END_XFORM_SKIP; diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index a7a72288aa..334870e141 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -23,33 +23,21 @@ All rights reserved. */ -/* This file contains - - * the main eval-apply loop, in scheme_do_eval() - - * the main compile loop, int scheme_compile_expand_expr() - - * compilation and bytecode [un]marshaling for - - applications - - sequences (along with code in syntax.c) - - branches (along with code in syntax.c) - - with-continuation-mark - [These are here instead of syntax.c because they are - tightly integrated into the evaluation loop.] - - * C and Scheme stack management routines +/* This file contains the main interpreter eval-apply loop, + scheme_do_eval(), C and Scheme stack management routines, + and other bridges between evaluation and compilation. Evaluation: - The bytecode evaluator uses the C stack for continuations, and a + The bytecode interpreter uses the C stack for continuations, and a separate Scheme stack for activation-frame variables and collecting - application arguments. Closures are flat, so mutable variables are - boxed. A third stack is used for continuation marks, only as - needed. + application arguments. Closures are (nearly) flat, so mutable + variables are boxed. A third stack is used for continuation marks, + only as needed. Tail calls are, for the most part, gotos within scheme_do_eval(). A C function called by the main evaluation loop can perform a - trampoling tail call via scheme_tail_apply. The trampoline must + trampoling tail call via scheme_tail_apply(). The trampoline must return to its caller without allocating any memory, because an allocation optimization in the tail-call code assumes no GCs will occur between the time that a tail call is issued and the time when @@ -59,21 +47,21 @@ token that indicates actual values are stored in the current thread's record. - The apply half of the eval-apply loop branches on all possible - application types. All primitive functions (including cons) are - implemented by C functions outside the loop. Continuation - applications are handled directly in scheme_do_eval(). That leaves - calls to closures, which are also performed within scheme_do_eval() - (so that most tail calls avoid the trampoline), and native code, - which is analogous to a primitive. + The `apply' half of the `eval--apply' loop branches on all possible + application types. Some functions can be JIT-generated native code, + so `apply' is the bridge from interpreted code to JITted + code. Primitive functions (including cons) are implemented by C + functions outside the loop. Continuation applications are handled + directly in scheme_do_eval(). That leaves calls to non-JITted + closures, which are also performed within scheme_do_eval() (so that + most tail calls avoid the trampoline), which is analogous to a + primitive. - The eval half of the loop detects a limited set of core syntactic - forms, such as application and letrecs. Otherwise, it dispatches to - external functions to implement elaborate syntactic forms, such as - begin0 and case-lambda expressions. + The `eval' half of the loop handles all core syntactic forms, such + as application and `letrec's. When collecting the arguments for an application, scheme_do_eval() - avoids recursive C calls to evaluate arguments by recogzining + avoids recursive C calls to evaluate arguments by recognizing easily-evaluated expressions, such as constrants and variable lookups. This can be viewed as a kind of half-way A-normalization. @@ -85,19 +73,23 @@ module is instantiated. Syntax constants are similarly accessed through the Scheme stack. The global variables and syntax objects are sometimes called the "prefix", and scheme_push_prefix() - initializes the prefix portion of the stack. + initializes the prefix portion of the stack. This prefix is + captured in a continuation that refers to global or module-level + variables (which is why the closure is not entirely flat). Special + GC support allows a prefix to be pruned to just the globals that + are used by live closures. - Compilation: + Bytecode compilation: Compilation works in four passes. The first pass, called "compile", performs most of the work and tracks variable usage (including whether a variable is mutated or - not). + not). See "compile.c" along with "compenv.c". The second pass, called "optimize", performs constant propagation, constant folding, and function inlining; this pass mutates records - produced by the first pass. + produced by the first pass. See "optimize.c". The third pass, called "resolve", finishes compilation by computing variable offsets and indirections (often mutating the records @@ -106,19 +98,34 @@ lifting (of procedures that close over nothing or only globals). Beware that the resulting bytecode object is a graph, not a tree, due to sharing (potentially cyclic) of closures that are "empty" - but actually refer to other "empty" closures. + but actually refer to other "empty" closures. See "resove.c". The fourth pass, "sfs", performs another liveness analysis on stack slows and inserts operations to clear stack slots as necessary to make execution safe for space. In particular, dead slots need to be cleared before a non-tail call into arbitrary Scheme code. This pass - can mutate the result of the "resolve" pass. + can mutate the result of the "resolve" pass. See "sfs.c". + + Bytecode marshaling and validation: + + See "marshal.c" for functions that [un]marshal bytecode form + to/from S-expressions (roughly), which can then be printed using a + "fast-load" format. + + The bytecode validator is applied to unmarshaled bytecode to check + that the bytecode is well formed and won't cause any segfaults in + the interpreter or in JITted form. See "validate.c". Just-in-time compilation: - If the JIT is enabled, then `eval' processes a compiled expression - one more time (functionally): `lambda' and `case-lambda' forms are - converted to native-code generators, instead of bytecode variants. + If the JIT is enabled, then `eval' processes (perhaps unmarshaled + and validated) bytecode one more time: `lambda' and `case-lambda' + forms are converted to native-code generators, instead of bytecode + variants. The code is not actually JITted until it is called; this + preparation step merely sets up a JIT hook for each function. The + preparation pass is a shallow, function (i.e., it doesn't mutate + the original bytecode) pass; the body of a fuction is preparred for + JITting lazily. See "jitprep.c". */ @@ -171,10 +178,7 @@ int scheme_get_overflow_count() { return scheme_overflow_count; } /* read-only globals */ READ_ONLY Scheme_Object *scheme_eval_waiting; READ_ONLY Scheme_Object *scheme_multiple_values; -READ_ONLY static Scheme_Object *app_expander; -READ_ONLY static Scheme_Object *datum_expander; -READ_ONLY static Scheme_Object *top_expander; -READ_ONLY static Scheme_Object *stop_expander; + /* symbols */ ROSYM static Scheme_Object *app_symbol; ROSYM static Scheme_Object *datum_symbol; @@ -193,8 +197,6 @@ ROSYM static Scheme_Object *internal_define_symbol; ROSYM static Scheme_Object *module_symbol; ROSYM static Scheme_Object *module_begin_symbol; ROSYM static Scheme_Object *expression_symbol; -ROSYM static Scheme_Object *values_symbol; -ROSYM static Scheme_Object *protected_symbol; ROSYM Scheme_Object *scheme_stack_dump_key; READ_ONLY static Scheme_Object *zero_rands_ptr; /* &zero_rands_ptr is dummy rands pointer */ @@ -227,39 +229,8 @@ static Scheme_Object *compile_module_constants(int argc, Scheme_Object **argv); static Scheme_Object *use_jit(int argc, Scheme_Object **argv); static Scheme_Object *disallow_inline(int argc, Scheme_Object **argv); -static Scheme_Object *app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); - -static Scheme_Object *write_application(Scheme_Object *obj); -static Scheme_Object *read_application(Scheme_Object *obj); -static Scheme_Object *write_sequence(Scheme_Object *obj); -static Scheme_Object *read_sequence(Scheme_Object *obj); -static Scheme_Object *read_sequence_save_first(Scheme_Object *obj); -static Scheme_Object *read_sequence_splice(Scheme_Object *obj); -static Scheme_Object *write_branch(Scheme_Object *obj); -static Scheme_Object *read_branch(Scheme_Object *obj); -static Scheme_Object *write_with_cont_mark(Scheme_Object *obj); -static Scheme_Object *read_with_cont_mark(Scheme_Object *obj); -static Scheme_Object *write_quote_syntax(Scheme_Object *obj); -static Scheme_Object *read_quote_syntax(Scheme_Object *obj); - -static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); - -static Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position); - static Scheme_Object *_eval_compiled_multi_with_prompt(Scheme_Object *obj, Scheme_Env *env); -static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_Info *info, int context, int rator_flags); -static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags); -static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimize_Info *info, int context, int rator_flags); - void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Object **rands, Scheme_Object *alt_full); #ifdef MZ_PRECISE_GC @@ -274,16 +245,6 @@ typedef void (*DW_PrePost_Proc)(void *); static void register_traversers(void); #endif -/* Lookahead types for evaluating application arguments. */ -/* 4 cases + else => magic number for some compilers doing a switch? */ -enum { - SCHEME_EVAL_CONSTANT = 0, - SCHEME_EVAL_GLOBAL, - SCHEME_EVAL_LOCAL, - SCHEME_EVAL_LOCAL_UNBOX, - SCHEME_EVAL_GENERAL -}; - #define icons scheme_make_pair /*========================================================================*/ @@ -322,7 +283,6 @@ scheme_init_eval (Scheme_Env *env) REGISTER_SO(letrec_syntaxes_symbol); REGISTER_SO(begin_symbol); REGISTER_SO(let_values_symbol); - REGISTER_SO(values_symbol); define_values_symbol = scheme_intern_symbol("define-values"); letrec_values_symbol = scheme_intern_symbol("letrec-values"); @@ -333,44 +293,30 @@ scheme_init_eval (Scheme_Env *env) quote_symbol = scheme_intern_symbol("quote"); letrec_syntaxes_symbol = scheme_intern_symbol("letrec-syntaxes+values"); begin_symbol = scheme_intern_symbol("begin"); - values_symbol = scheme_intern_symbol("values"); REGISTER_SO(module_symbol); REGISTER_SO(module_begin_symbol); REGISTER_SO(internal_define_symbol); REGISTER_SO(expression_symbol); REGISTER_SO(top_level_symbol); - REGISTER_SO(protected_symbol); module_symbol = scheme_intern_symbol("module"); module_begin_symbol = scheme_intern_symbol("module-begin"); internal_define_symbol = scheme_intern_symbol("internal-define"); expression_symbol = scheme_intern_symbol("expression"); top_level_symbol = scheme_intern_symbol("top-level"); - protected_symbol = scheme_intern_symbol("protected"); + + REGISTER_SO(app_symbol); + REGISTER_SO(datum_symbol); + REGISTER_SO(top_symbol); + + app_symbol = scheme_intern_symbol("#%app"); + datum_symbol = scheme_intern_symbol("#%datum"); + top_symbol = scheme_intern_symbol("#%top"); REGISTER_SO(scheme_stack_dump_key); scheme_stack_dump_key = scheme_make_symbol("stk"); /* uninterned! */ - scheme_install_type_writer(scheme_application_type, write_application); - scheme_install_type_reader(scheme_application_type, read_application); - scheme_install_type_writer(scheme_application2_type, write_application); - scheme_install_type_reader(scheme_application2_type, read_application); - scheme_install_type_writer(scheme_application3_type, write_application); - scheme_install_type_reader(scheme_application3_type, read_application); - scheme_install_type_writer(scheme_sequence_type, write_sequence); - scheme_install_type_reader(scheme_sequence_type, read_sequence); - scheme_install_type_writer(scheme_branch_type, write_branch); - scheme_install_type_reader(scheme_branch_type, read_branch); - scheme_install_type_writer(scheme_with_cont_mark_type, write_with_cont_mark); - scheme_install_type_reader(scheme_with_cont_mark_type, read_with_cont_mark); - scheme_install_type_writer(scheme_quote_syntax_type, write_quote_syntax); - scheme_install_type_reader(scheme_quote_syntax_type, read_quote_syntax); - scheme_install_type_writer(scheme_begin0_sequence_type, write_sequence); - scheme_install_type_reader(scheme_begin0_sequence_type, read_sequence_save_first); - scheme_install_type_writer(scheme_splice_sequence_type, write_sequence); - scheme_install_type_reader(scheme_splice_sequence_type, read_sequence_splice); - GLOBAL_PRIM_W_ARITY2("eval", eval, 1, 2, 0, -1, env); GLOBAL_PRIM_W_ARITY2("eval-syntax", eval_stx, 1, 2, 0, -1, env); @@ -398,27 +344,6 @@ scheme_init_eval (Scheme_Env *env) GLOBAL_PARAMETER("compile-enforce-module-constants", compile_module_constants, MZCONFIG_COMPILE_MODULE_CONSTS, env); GLOBAL_PARAMETER("eval-jit-enabled", use_jit, MZCONFIG_USE_JIT, env); GLOBAL_PARAMETER("compile-context-preservation-enabled", disallow_inline, MZCONFIG_DISALLOW_INLINE, env); - - REGISTER_SO(app_symbol); - REGISTER_SO(datum_symbol); - REGISTER_SO(top_symbol); - - app_symbol = scheme_intern_symbol("#%app"); - datum_symbol = scheme_intern_symbol("#%datum"); - top_symbol = scheme_intern_symbol("#%top"); - - REGISTER_SO(app_expander); - REGISTER_SO(datum_expander); - REGISTER_SO(top_expander); - REGISTER_SO(stop_expander); - - app_expander = scheme_make_compiled_syntax(app_syntax, app_expand); - datum_expander = scheme_make_compiled_syntax(datum_syntax, datum_expand); - top_expander = scheme_make_compiled_syntax(top_syntax, top_expand); - stop_expander = scheme_make_compiled_syntax(stop_syntax, stop_expand); - scheme_add_global_keyword("#%app", app_expander, env); - scheme_add_global_keyword("#%datum", datum_expander, env); - scheme_add_global_keyword("#%top", top_expander, env); } void scheme_init_eval_places() @@ -435,12 +360,6 @@ void scheme_init_eval_places() /* C stack and Scheme stack handling */ /*========================================================================*/ -# define DO_CHECK_FOR_BREAK(p, e) \ - if (DECREMENT_FUEL(scheme_fuel_counter, 1) <= 0) { \ - e scheme_thread_block(0); \ - (p)->ran_some = 1; \ - } - Scheme_Object * scheme_handle_stack_overflow(Scheme_Object *(*k)(void)) { @@ -705,1152 +624,9 @@ void *scheme_enlarge_runstack(intptr_t size, void *(*k)()) } /*========================================================================*/ -/* compiling applications, sequences, and branches */ +/* linking variables */ /*========================================================================*/ -static int is_current_inspector_call(Scheme_Object *a) -{ - if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { - Scheme_App_Rec *app = (Scheme_App_Rec *)a; - if (!app->num_args - && SAME_OBJ(app->args[0], scheme_current_inspector_proc)) - return 1; - } - return 0; -} - -static int is_proc_spec_proc(Scheme_Object *p) -{ - Scheme_Type vtype; - - if (SCHEME_PROCP(p)) { - p = scheme_get_or_check_arity(p, -1); - if (SCHEME_INTP(p)) { - return (SCHEME_INT_VAL(p) >= 1); - } else if (SCHEME_STRUCTP(p) - && scheme_is_struct_instance(scheme_arity_at_least, p)) { - p = ((Scheme_Structure *)p)->slots[0]; - if (SCHEME_INTP(p)) - return (SCHEME_INT_VAL(p) >= 1); - } - return 0; - } - - vtype = SCHEME_TYPE(p); - - if (vtype == scheme_unclosed_procedure_type) { - if (((Scheme_Closure_Data *)p)->num_params >= 1) - return 1; - } - - return 0; -} - -static void note_match(int actual, int expected, Optimize_Info *warn_info) -{ - if (!warn_info || (expected == -1)) - return; - - if (actual != expected) { - scheme_log(NULL, - SCHEME_LOG_WARNING, - 0, - "warning%s: optimizer detects %d values produced when %d expected", - scheme_optimize_context_to_string(warn_info->context), - actual, expected); - } -} - -int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, - Optimize_Info *warn_info, int deeper_than) - /* Checks whether the bytecode `o' returns `vals' values with no - side-effects and without pushing and using continuation marks. - -1 for vals means that any return count is ok. - Also used with fully resolved expression by `module' to check - for "functional" bodies. - If warn_info is supplied, complain when a mismatch is detected. */ -{ - Scheme_Type vtype; - - /* FIXME: can overflow the stack */ - - try_again: - - vtype = SCHEME_TYPE(o); - - if ((vtype > _scheme_compiled_values_types_) - || ((vtype == scheme_local_type) - && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ) - && (SCHEME_LOCAL_POS(o) > deeper_than)) - || ((vtype == scheme_local_unbox_type) - && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ) - && (SCHEME_LOCAL_POS(o) > deeper_than)) - || (vtype == scheme_unclosed_procedure_type) - || (vtype == scheme_compiled_unclosed_procedure_type) - || (vtype == scheme_case_lambda_sequence_type) - || (vtype == scheme_case_lambda_sequence_type) - || (vtype == scheme_quote_syntax_type) - || (vtype == scheme_compiled_quote_syntax_type)) { - note_match(1, vals, warn_info); - return ((vals == 1) || (vals < 0)); - } - - if (vtype == scheme_toplevel_type) { - note_match(1, vals, warn_info); - if (resolved && ((vals == 1) || (vals < 0))) { - if (SCHEME_TOPLEVEL_FLAGS(o) - & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY)) - return 1; - else - return 0; - } - } - - if (vtype == scheme_compiled_toplevel_type) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - if (SCHEME_TOPLEVEL_FLAGS(o) - & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY)) - return 1; - else - return 0; - } - } - - if (vtype == scheme_case_lambda_sequence_type) { - note_match(1, vals, warn_info); - return 1; - } - - if ((vtype == scheme_compiled_quote_syntax_type)) { - note_match(1, vals, warn_info); - return ((vals == 1) || (vals < 0)); - } - - if ((vtype == scheme_branch_type)) { - Scheme_Branch_Rec *b; - b = (Scheme_Branch_Rec *)o; - return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info, deeper_than) - && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info, deeper_than) - && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info, deeper_than)); - } - -#if 0 - /* We can't do this because a set! to a lexical is turned into - a let_value_type! */ - if ((vtype == scheme_let_value_type)) { - Scheme_Let_Value *lv = (Scheme_Let_Value *)o; - return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, warn_info, deeper_than) - && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info, deeper_than)); - } -#endif - - if ((vtype == scheme_let_one_type)) { - Scheme_Let_One *lo = (Scheme_Let_One *)o; - return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1) - && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info, deeper_than + 1)); - } - - if ((vtype == scheme_let_void_type)) { - Scheme_Let_Void *lv = (Scheme_Let_Void *)o; - /* recognize (letrec ([x ]) ...): */ - if (SAME_TYPE(SCHEME_TYPE(lv->body), scheme_let_value_type)) { - Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body; - if ((lv2->count == 1) - && (lv2->position == 0) - && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, warn_info, - deeper_than + 1 + lv->count)) { - o = lv2->body; - deeper_than += 1; - } else - o = lv->body; - } else - o = lv->body; - deeper_than += lv->count; - goto try_again; - } - - if ((vtype == scheme_compiled_let_void_type)) { - /* recognize another (let ([x ]) ...) pattern: */ - Scheme_Let_Header *lh = (Scheme_Let_Header *)o; - if ((lh->count == 1) && (lh->num_clauses == 1)) { - if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { - Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1)) { - o = lv->body; - deeper_than++; - goto try_again; - } - } - } - } - - if ((vtype == scheme_letrec_type)) { - o = ((Scheme_Letrec *)o)->body; - goto try_again; - } - - if ((vtype == scheme_application_type)) { - /* Look for multiple values, or for `make-struct-type'. - (The latter is especially useful to Honu.) */ - Scheme_App_Rec *app = (Scheme_App_Rec *)o; - if ((app->num_args >= 4) && (app->num_args <= 10) - && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { - note_match(5, vals, warn_info); - if ((vals == 5) || (vals < 0)) { - /* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */ - if (SCHEME_SYMBOLP(app->args[1]) - && SCHEME_FALSEP(app->args[2]) - && SCHEME_INTP(app->args[3]) - && (SCHEME_INT_VAL(app->args[3]) >= 0) - && SCHEME_INTP(app->args[4]) - && (SCHEME_INT_VAL(app->args[4]) >= 0) - && ((app->num_args < 5) - || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0))) - && ((app->num_args < 6) - || SCHEME_NULLP(app->args[6])) - && ((app->num_args < 7) - || SCHEME_FALSEP(app->args[7]) - || is_current_inspector_call(app->args[7])) - && ((app->num_args < 8) - || SCHEME_FALSEP(app->args[8]) - || is_proc_spec_proc(app->args[8])) - && ((app->num_args < 9) - || SCHEME_NULLP(app->args[9]))) { - return 1; - } - } - } - /* (values ...) */ - if (SAME_OBJ(scheme_values_func, app->args[0])) { - note_match(app->num_args, vals, warn_info); - if ((app->num_args == vals) || (vals < 0)) { - int i; - for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0))) - return 0; - } - return 1; - } - } - /* ({void,list,list*,vector,vector-immutable} ...) */ - if (SAME_OBJ(scheme_void_proc, app->args[0]) - || SAME_OBJ(scheme_list_proc, app->args[0]) - || SAME_OBJ(scheme_list_star_proc, app->args[0]) - || SAME_OBJ(scheme_vector_proc, app->args[0]) - || SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - int i; - for (i = app->num_args; i--; ) { - if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? app->num_args : 0))) - return 0; - } - return 1; - } - } - if (SCHEME_PRIMP(app->args[0]) - && (SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) - && (app->num_args >= ((Scheme_Primitive_Proc *)app->args[0])->mina) - && (app->num_args <= ((Scheme_Primitive_Proc *)app->args[0])->mu.maxa)) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - /* can omit an unsafe op */ - return 1; - } - } - return 0; - } - - if ((vtype == scheme_application2_type)) { - /* ({values,void,list,list*,vector,vector-immutable,box} ) */ - Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; - if (SAME_OBJ(scheme_values_func, app->rator) - || SAME_OBJ(scheme_void_proc, app->rator) - || SAME_OBJ(scheme_list_proc, app->rator) - || SAME_OBJ(scheme_list_star_proc, app->rator) - || SAME_OBJ(scheme_vector_proc, app->rator) - || SAME_OBJ(scheme_vector_immutable_proc, app->rator) - || SAME_OBJ(scheme_box_proc, app->rator)) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 1 : 0))) - return 1; - } - } - if (SCHEME_PRIMP(app->rator) - && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) - && (1 >= ((Scheme_Primitive_Proc *)app->rator)->mina) - && (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 1 : 0))) - return 1; - } - } - return 0; - } - - if ((vtype == scheme_application3_type)) { - /* (values ) */ - Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; - if (SAME_OBJ(scheme_values_func, app->rator)) { - note_match(2, vals, warn_info); - if ((vals == 2) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0)) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0))) - return 1; - } - } - /* ({void,cons,list,list*,vector,vector-immutable) ) */ - if (SAME_OBJ(scheme_void_proc, app->rator) - || SAME_OBJ(scheme_cons_proc, app->rator) - || SAME_OBJ(scheme_mcons_proc, app->rator) - || SAME_OBJ(scheme_list_proc, app->rator) - || SAME_OBJ(scheme_list_star_proc, app->rator) - || SAME_OBJ(scheme_vector_proc, app->rator) - || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0)) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0))) - return 1; - } - } - if (SCHEME_PRIMP(app->rator) - && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) - && (2 >= ((Scheme_Primitive_Proc *)app->rator)->mina) - && (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { - note_match(1, vals, warn_info); - if ((vals == 1) || (vals < 0)) { - if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0)) - && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, - deeper_than + (resolved ? 2 : 0))) - return 1; - } - } - } - - return 0; -} - -static int single_valued_noncm_expression(Scheme_Object *expr, int fuel) -/* Non-omittable but single-valued expresions that are not sensitive - to being in tail position. */ -{ - Scheme_Object *rator = NULL; - - switch (SCHEME_TYPE(expr)) { - case scheme_toplevel_type: - return 1; - case scheme_application_type: - rator = ((Scheme_App_Rec *)expr)->args[0]; - break; - case scheme_application2_type: - rator = ((Scheme_App2_Rec *)expr)->rator; - break; - case scheme_application3_type: - rator = ((Scheme_App2_Rec *)expr)->rator; - break; - case scheme_compiled_let_void_type: - { - Scheme_Let_Header *lh = (Scheme_Let_Header *)expr; - Scheme_Compiled_Let_Value *clv; - if ((lh->count == 1) && (lh->num_clauses == 1) && (fuel > 0)) { - clv = (Scheme_Compiled_Let_Value *)lh->body; - return single_valued_noncm_expression(clv->body, fuel - 1); - } - } - break; - } - - if (rator && SCHEME_PRIMP(rator)) { - int opt; - opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; - if (opt >= SCHEME_PRIM_OPT_NONCM) - return 1; - } - - return 0; -} - -int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be_liftable) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type)) { - if (!can_be_closed || !can_be_liftable) { - Scheme_Closure_Data *data; - data = (Scheme_Closure_Data *)o; - /* Because == 0 is like a constant */ - if (!can_be_closed && !data->closure_size) - return 0; - /* Because procs that reference only globals are lifted: */ - if (!can_be_liftable && (data->closure_size == 1) && scheme_closure_has_top_level(data)) - return 0; - } - return 1; - } else - return 0; -} - -int scheme_get_eval_type(Scheme_Object *obj) - /* Categories for short-cutting recursive calls to the evaluator */ -{ - Scheme_Type type; - - type = SCHEME_TYPE(obj); - - if (type > _scheme_values_types_) - return SCHEME_EVAL_CONSTANT; - else if (SAME_TYPE(type, scheme_local_type)) - return SCHEME_EVAL_LOCAL; - else if (SAME_TYPE(type, scheme_local_unbox_type)) - return SCHEME_EVAL_LOCAL_UNBOX; - else if (SAME_TYPE(type, scheme_toplevel_type)) - return SCHEME_EVAL_GLOBAL; - else - return SCHEME_EVAL_GENERAL; -} - -static Scheme_Object *try_apply(Scheme_Object *f, Scheme_Object *args, Scheme_Object *context) - /* Apply `f' to `args' and ignore failues --- used for constant - folding attempts */ -{ - Scheme_Object * volatile result; - Scheme_Object * volatile exn = NULL; - mz_jmp_buf *savebuf, newbuf; - - scheme_current_thread->reading_delayed = NULL; - scheme_current_thread->constant_folding = (context ? context : scheme_true); - savebuf = scheme_current_thread->error_buf; - scheme_current_thread->error_buf = &newbuf; - - if (scheme_setjmp(newbuf)) { - result = NULL; - exn = scheme_current_thread->reading_delayed; - } else - result = _scheme_apply_to_list(f, args); - - scheme_current_thread->error_buf = savebuf; - scheme_current_thread->constant_folding = NULL; - scheme_current_thread->reading_delayed = NULL; - - if (scheme_current_thread->cjs.is_kill) { - scheme_longjmp(*scheme_current_thread->error_buf, 1); - } - - if (exn) - scheme_raise(exn); - - return result; -} - -static int foldable_body(Scheme_Object *f) -{ - Scheme_Closure_Data *d; - - d = SCHEME_COMPILED_CLOS_CODE(f); - - scheme_delay_load_closure(d); - - return (SCHEME_TYPE(d->code) > _scheme_values_types_); -} - -static Scheme_Object *make_application(Scheme_Object *v) -{ - Scheme_Object *o; - int i, nv; - volatile int n; - - o = v; - n = 0; - nv = 0; - while (!SCHEME_NULLP(o)) { - Scheme_Type type; - - n++; - type = SCHEME_TYPE(SCHEME_CAR(o)); - if (type < _scheme_compiled_values_types_) - nv = 1; - o = SCHEME_CDR(o); - } - - if (!nv) { - /* They're all values. Applying folding prim or closure? */ - Scheme_Object *f; - - f = SCHEME_CAR(v); - - if ((SCHEME_PRIMP(f) && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) - == SCHEME_PRIM_OPT_FOLDING)) - || (SCHEME_CLSD_PRIMP(f) - && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) - == SCHEME_PRIM_OPT_FOLDING)) - || (SAME_TYPE(SCHEME_TYPE(f), scheme_closure_type) - && (foldable_body(f)))) { - f = try_apply(f, SCHEME_CDR(v), scheme_false); - - if (f) - return f; - } - } - - if (n == 2) { - Scheme_App2_Rec *app; - - app = MALLOC_ONE_TAGGED(Scheme_App2_Rec); - app->iso.so.type = scheme_application2_type; - - app->rator = SCHEME_CAR(v); - v = SCHEME_CDR(v); - app->rand = SCHEME_CAR(v); - - return (Scheme_Object *)app; - } else if (n == 3) { - Scheme_App3_Rec *app; - - app = MALLOC_ONE_TAGGED(Scheme_App3_Rec); - app->iso.so.type = scheme_application3_type; - - app->rator = SCHEME_CAR(v); - v = SCHEME_CDR(v); - app->rand1 = SCHEME_CAR(v); - v = SCHEME_CDR(v); - app->rand2 = SCHEME_CAR(v); - - return (Scheme_Object *)app; - } else { - Scheme_App_Rec *app; - - app = scheme_malloc_application(n); - - for (i = 0; i < n; i++, v = SCHEME_CDR(v)) { - app->args[i] = SCHEME_CAR(v); - } - - return (Scheme_Object *)app; - } -} - -Scheme_App_Rec *scheme_malloc_application(int n) -{ - Scheme_App_Rec *app; - int size; - - size = (sizeof(Scheme_App_Rec) - + ((n - 1) * sizeof(Scheme_Object *)) - + n * sizeof(char)); - app = (Scheme_App_Rec *)scheme_malloc_tagged(size); - - app->so.type = scheme_application_type; - - app->num_args = n - 1; - - return app; -} - -void scheme_finish_application(Scheme_App_Rec *app) -{ - int i, devals, n; - - n = app->num_args + 1; - - devals = sizeof(Scheme_App_Rec) + (app->num_args * sizeof(Scheme_Object *)); - - for (i = 0; i < n; i++) { - char etype; - etype = scheme_get_eval_type(app->args[i]); - ((char *)app XFORM_OK_PLUS devals)[i] = etype; - } -} - -static Scheme_Object *check_converted_rator(Scheme_Object *rator, Resolve_Info *info, Scheme_Object **new_rator, - int orig_arg_cnt, int *_rdelta) -{ - Scheme_Object *lifted; - int flags; - - if (!SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) - return NULL; - - (void)scheme_resolve_info_lookup(info, SCHEME_LOCAL_POS(rator), &flags, &lifted, orig_arg_cnt + 1); - - if (lifted && SCHEME_RPAIRP(lifted)) { - Scheme_Object *vec, *arity; - - *new_rator = SCHEME_CAR(lifted); - vec = SCHEME_CDR(lifted); - *_rdelta = 0; - - if (SCHEME_VEC_SIZE(vec) > 1) { - /* Check that actual argument count matches expected. If - it doesn't, we need to generate explicit code to report - the error, so that the conversion's arity change isn't - visible. */ - arity = SCHEME_VEC_ELS(vec)[0]; - if (SCHEME_INTP(arity)) { - if (orig_arg_cnt == SCHEME_INT_VAL(arity)) - arity = NULL; - } else { - arity = SCHEME_BOX_VAL(arity); - if (orig_arg_cnt >= SCHEME_INT_VAL(arity)) - arity = NULL; - else { - Scheme_App2_Rec *app; - app = MALLOC_ONE_TAGGED(Scheme_App2_Rec); - app->iso.so.type = scheme_application2_type; - app->rator = scheme_make_arity_at_least; - app->rand = arity; - arity = (Scheme_Object *)app; - *_rdelta = 1; /* so app gets resolved */ - } - } - /* If arity is non-NULL, there's a mismatch. */ - if (arity) { - /* Generate a call to `raise-arity-error' instead of - the current *new_rator: */ - Scheme_Object *old_rator = *new_rator; - if (SAME_TYPE(SCHEME_TYPE(old_rator), scheme_toplevel_type)) { - /* More coordinate trouble. old_rator was computed for an - application with a potentially different number of arguments. */ - int delta; - delta = 3 - SCHEME_VEC_SIZE(vec); - if (delta) - old_rator = scheme_shift_toplevel(old_rator, delta); - } - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(0); - SCHEME_VEC_ELS(vec)[1] = old_rator; - SCHEME_VEC_ELS(vec)[2] = arity; - *new_rator = scheme_raise_arity_error_proc; - } - } - - return vec; - } else - return NULL; -} - -static Scheme_Object *resolve_application(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count) -{ - Resolve_Info *info; - Scheme_App_Rec *app; - int i, n, devals; - - app = (Scheme_App_Rec *)o; - - n = app->num_args + 1; - - if (!already_resolved_arg_count) { - /* Check whether this is an application of a converted closure: */ - Scheme_Object *additions = NULL, *rator; - int rdelta; - additions = check_converted_rator(app->args[0], orig_info, &rator, n - 1, &rdelta); - if (additions) { - /* Expand application with m arguments */ - Scheme_App_Rec *app2; - Scheme_Object *loc; - int m; - m = SCHEME_VEC_SIZE(additions) - 1; - app2 = scheme_malloc_application(n + m); - for (i = 0; i < m; i++) { - loc = SCHEME_VEC_ELS(additions)[i+1]; - if (SCHEME_BOXP(loc)) - loc = SCHEME_BOX_VAL(loc); - else if (SCHEME_VECTORP(loc)) - loc = SCHEME_VEC_ELS(loc)[0]; - app2->args[i + 1] = loc; - } - for (i = 1; i < n; i++) { - app2->args[i + m] = app->args[i]; - } - app2->args[0] = rator; - n += m; - app = app2; - already_resolved_arg_count = m + 1 + rdelta; - } - } - - devals = sizeof(Scheme_App_Rec) + ((n - 1) * sizeof(Scheme_Object *)); - - info = scheme_resolve_info_extend(orig_info, n - 1, 0, 0); - - for (i = 0; i < n; i++) { - Scheme_Object *le; - if (already_resolved_arg_count) { - already_resolved_arg_count--; - } else { - le = scheme_resolve_expr(app->args[i], info); - app->args[i] = le; - } - } - - info->max_let_depth += (n - 1); - if (orig_info->max_let_depth < info->max_let_depth) - orig_info->max_let_depth = info->max_let_depth; - scheme_merge_resolve_tl_map(orig_info, info); - - for (i = 0; i < n; i++) { - char et; - et = scheme_get_eval_type(app->args[i]); - ((char *)app XFORM_OK_PLUS devals)[i] = et; - } - - return (Scheme_Object *)app; -} - -static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count); - -static void set_app2_eval_type(Scheme_App2_Rec *app) -{ - short et; - - et = scheme_get_eval_type(app->rand); - et = et << 3; - et += scheme_get_eval_type(app->rator); - - SCHEME_APPN_FLAGS(app) = et; -} - -void scheme_reset_app2_eval_type(Scheme_App2_Rec *app) -{ - set_app2_eval_type(app); -} - -static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count) -{ - Resolve_Info *info; - Scheme_App2_Rec *app; - Scheme_Object *le; - - app = (Scheme_App2_Rec *)o; - - if (!already_resolved_arg_count) { - /* Check whether this is an application of a converted closure: */ - Scheme_Object *additions = NULL, *rator; - int rdelta; - additions = check_converted_rator(app->rator, orig_info, &rator, 1, &rdelta); - if (additions) { - int m; - m = SCHEME_VEC_SIZE(additions) - 1; - if (!m) { - app->rator = rator; - already_resolved_arg_count = 1 + rdelta; - } else if (m > 1) { - /* Expand application with m arguments */ - Scheme_App_Rec *app2; - Scheme_Object *loc; - int i; - app2 = scheme_malloc_application(2 + m); - for (i = 0; i < m; i++) { - loc = SCHEME_VEC_ELS(additions)[i+1]; - if (SCHEME_BOXP(loc)) - loc = SCHEME_BOX_VAL(loc); - else if (SCHEME_VECTORP(loc)) - loc = SCHEME_VEC_ELS(loc)[0]; - app2->args[i + 1] = loc; - } - app2->args[0] = rator; - app2->args[m+1] = app->rand; - return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta); - } else { - Scheme_App3_Rec *app2; - Scheme_Object *loc; - app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec); - app2->iso.so.type = scheme_application3_type; - app2->rator = rator; - loc = SCHEME_VEC_ELS(additions)[1]; - if (SCHEME_BOXP(loc)) - loc = SCHEME_BOX_VAL(loc); - else if (SCHEME_VECTORP(loc)) - loc = SCHEME_VEC_ELS(loc)[0]; - app2->rand1 = loc; - app2->rand2 = app->rand; - return resolve_application3((Scheme_Object *)app2, orig_info, 2 + rdelta); - } - } - } - - info = scheme_resolve_info_extend(orig_info, 1, 0, 0); - - if (!already_resolved_arg_count) { - le = scheme_resolve_expr(app->rator, info); - app->rator = le; - } else - already_resolved_arg_count--; - - if (!already_resolved_arg_count) { - le = scheme_resolve_expr(app->rand, info); - app->rand = le; - } else - already_resolved_arg_count--; - - info->max_let_depth += 1; - if (orig_info->max_let_depth < info->max_let_depth) - orig_info->max_let_depth = info->max_let_depth; - scheme_merge_resolve_tl_map(orig_info, info); - - set_app2_eval_type(app); - - return (Scheme_Object *)app; -} - -static int eq_testable_constant(Scheme_Object *v) -{ - if (SCHEME_SYMBOLP(v) - || SCHEME_FALSEP(v) - || SAME_OBJ(v, scheme_true) - || SCHEME_VOIDP(v)) - return 1; - - if (SCHEME_CHARP(v) && (SCHEME_CHAR_VAL(v) < 256)) - return 1; - - if (SCHEME_INTP(v) - && (SCHEME_INT_VAL(v) < (1 << 29)) - && (SCHEME_INT_VAL(v) > -(1 << 29))) - return 1; - - return 0; -} - -static void set_app3_eval_type(Scheme_App3_Rec *app) -{ - short et; - - et = scheme_get_eval_type(app->rand2); - et = et << 3; - et += scheme_get_eval_type(app->rand1); - et = et << 3; - et += scheme_get_eval_type(app->rator); - - SCHEME_APPN_FLAGS(app) = et; -} - -static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count) -{ - Resolve_Info *info; - Scheme_App3_Rec *app; - Scheme_Object *le; - - app = (Scheme_App3_Rec *)o; - - if (!already_resolved_arg_count) { - /* Check whether this is an application of a converted closure: */ - Scheme_Object *additions = NULL, *rator; - int rdelta; - additions = check_converted_rator(app->rator, orig_info, &rator, 2, &rdelta); - if (additions) { - int m, i; - m = SCHEME_VEC_SIZE(additions) - 1; - if (m) { - /* Expand application with m arguments */ - Scheme_App_Rec *app2; - Scheme_Object *loc; - app2 = scheme_malloc_application(3 + m); - for (i = 0; i < m; i++) { - loc = SCHEME_VEC_ELS(additions)[i+1]; - if (SCHEME_BOXP(loc)) - loc = SCHEME_BOX_VAL(loc); - else if (SCHEME_VECTORP(loc)) - loc = SCHEME_VEC_ELS(loc)[0]; - app2->args[i + 1] = loc; - } - app2->args[0] = rator; - app2->args[m+1] = app->rand1; - app2->args[m+2] = app->rand2; - return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta); - } else { - app->rator = rator; - already_resolved_arg_count = 1 + rdelta; - } - } - } - - info = scheme_resolve_info_extend(orig_info, 2, 0, 0); - - if (already_resolved_arg_count) { - already_resolved_arg_count--; - } else { - le = scheme_resolve_expr(app->rator, info); - app->rator = le; - } - - if (already_resolved_arg_count) { - already_resolved_arg_count--; - } else { - le = scheme_resolve_expr(app->rand1, info); - app->rand1 = le; - } - - if (already_resolved_arg_count) { - already_resolved_arg_count--; - } else { - le = scheme_resolve_expr(app->rand2, info); - app->rand2 = le; - } - - /* Optimize `equal?' or `eqv?' test on certain types - to `eq?'. This is especially helpful for the JIT. */ - if ((SAME_OBJ(app->rator, scheme_equal_prim) - || SAME_OBJ(app->rator, scheme_eqv_prim)) - && (eq_testable_constant(app->rand1) - || eq_testable_constant(app->rand2))) { - app->rator = scheme_eq_prim; - } - - set_app3_eval_type(app); - - info->max_let_depth += 2; - if (orig_info->max_let_depth < info->max_let_depth) - orig_info->max_let_depth = info->max_let_depth; - scheme_merge_resolve_tl_map(orig_info, info); - - return (Scheme_Object *)app; -} - -Scheme_Object * -scheme_make_branch(Scheme_Object *test, Scheme_Object *thenp, - Scheme_Object *elsep) -{ - Scheme_Branch_Rec *b; - - if (SCHEME_TYPE(test) > _scheme_compiled_values_types_) { - if (SCHEME_FALSEP(test)) - return elsep; - else - return thenp; - } - - b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); - b->so.type = scheme_branch_type; - - b->test = test; - b->tbranch = thenp; - b->fbranch = elsep; - - return (Scheme_Object *)b; -} - -static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info) -{ - Scheme_Branch_Rec *b; - Scheme_Object *t, *tb, *fb; - - b = (Scheme_Branch_Rec *)o; - - t = scheme_resolve_expr(b->test, info); - tb = scheme_resolve_expr(b->tbranch, info); - fb = scheme_resolve_expr(b->fbranch, info); - - b->test = t; - b->tbranch = tb; - b->fbranch = fb; - - return o; -} - -static Scheme_Object *resolve_wcm(Scheme_Object *o, Resolve_Info *info) -{ - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; - Scheme_Object *k, *v, *b; - - k = scheme_resolve_expr(wcm->key, info); - v = scheme_resolve_expr(wcm->val, info); - b = scheme_resolve_expr(wcm->body, info); - wcm->key = k; - wcm->val = v; - wcm->body = b; - - return (Scheme_Object *)wcm; -} - -static Scheme_Sequence *malloc_sequence(int count) -{ - return (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence) - + (count - 1) - * sizeof(Scheme_Object *)); -} - -Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *seq, int opt) -{ - /* We have to be defensive in processing `seq'; it might be bad due - to a bad .zo */ - Scheme_Object *list, *v, *good; - Scheme_Sequence *o; - int count, i, k, total, last, first, setgood, addconst; - Scheme_Type type; - - type = scheme_sequence_type; - - list = seq; - count = i = 0; - good = NULL; - total = 0; - first = 1; - setgood = 1; - while (SCHEME_PAIRP(list)) { - v = SCHEME_CAR(list); - list = SCHEME_CDR(list); - last = SCHEME_NULLP(list); - - if (((opt > 0) || !first) && SAME_TYPE(SCHEME_TYPE(v), type)) { - /* "Inline" nested begins */ - count += ((Scheme_Sequence *)v)->count; - total++; - } else if (opt - && (((opt > 0) && !last) || ((opt < 0) && !first)) - && scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) { - /* A value that is not the result. We'll drop it. */ - total++; - } else { - if (setgood) - good = v; - count++; - total++; - } - i++; - if (first) { - if (opt < 0) - setgood = 0; - first = 0; - } - } - - if (!SCHEME_NULLP(list)) - return NULL; /* bad .zo */ - - if (!count) - return scheme_compiled_void(); - - if (count == 1) { - if (opt < -1) { - /* can't optimize away a begin0 at read time; it's too late, since the - return is combined with EXPD_BEGIN0 */ - addconst = 1; - } else if ((opt < 0) && !scheme_omittable_expr(SCHEME_CAR(seq), 1, -1, 0, NULL, -1)) { - /* We can't optimize (begin0 expr cont) to expr because - exp is not in tail position in the original (so we'd mess - up continuation marks). */ - addconst = 1; - } else - return good; - } else - addconst = 0; - - o = malloc_sequence(count + addconst); - - o->so.type = ((opt < 0) ? scheme_begin0_sequence_type : scheme_sequence_type); - o->count = count + addconst; - - --total; - for (i = k = 0; i < count; k++) { - v = SCHEME_CAR(seq); - seq = SCHEME_CDR(seq); - - if (((opt > 0) || k) && SAME_TYPE(SCHEME_TYPE(v), type)) { - int c, j; - Scheme_Object **a; - - c = ((Scheme_Sequence *)v)->count; - a = ((Scheme_Sequence *)v)->array; /* <-- mismaligned for precise GC */ - for (j = 0; j < c; j++) { - o->array[i++] = a[j]; - } - } else if (opt - && (((opt > 0) && (k < total)) - || ((opt < 0) && k)) - && scheme_omittable_expr(v, -1, -1, 0, NULL, -1)) { - /* Value not the result. Do nothing. */ - } else - o->array[i++] = v; - } - - if (addconst) - o->array[i] = scheme_make_integer(0); - - return (Scheme_Object *)o; -} - -static Scheme_Object *look_for_letv_change(Scheme_Sequence *s) -{ - int i; - - /* Change (begin e1 ... (set!-for-let [x 10] (void)) e2 ...) - to (begin e1 ... (set!-for-let [x 10] e2 ...)), which - avoids an unneeded recursive call in the evaluator */ - - for (i = 0; i < s->count - 1; i++) { - Scheme_Object *v; - v = s->array[i]; - if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) { - Scheme_Let_Value *lv = (Scheme_Let_Value *)v; - if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL, -1)) { - int esize = s->count - (i + 1); - int nsize = i + 1; - Scheme_Object *nv, *ev; - - if (nsize > 1) { - Scheme_Sequence *naya; - - naya = malloc_sequence(nsize); - naya->so.type = s->so.type; - naya->count = nsize; - nv = (Scheme_Object *)naya; - - for (i = 0; i < nsize; i++) { - naya->array[i] = s->array[i]; - } - } else - nv = (Scheme_Object *)lv; - - if (esize > 1) { - Scheme_Sequence *e; - e = malloc_sequence(esize); - e->so.type = s->so.type; - e->count = esize; - - for (i = 0; i < esize; i++) { - e->array[i] = s->array[i + nsize]; - } - - ev = (Scheme_Object *)look_for_letv_change(e); - } else - ev = s->array[nsize]; - - lv->body = ev; - - return nv; - } - } - } - - return (Scheme_Object *)s; -} - -static Scheme_Object *resolve_sequence(Scheme_Object *o, Resolve_Info *info) -{ - Scheme_Sequence *s = (Scheme_Sequence *)o; - int i; - - for (i = s->count; i--; ) { - Scheme_Object *le; - le = scheme_resolve_expr(s->array[i], info); - s->array[i] = le; - } - - return look_for_letv_change(s); -} - static Scheme_Object *link_module_variable(Scheme_Object *modidx, Scheme_Object *varname, int check_access, Scheme_Object *insp, @@ -2000,6410 +776,6 @@ static Scheme_Object *link_toplevel(Scheme_Object **exprs, int which, Scheme_Env } } -static Scheme_Object *resolve_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1; - Resolve_Info *info = (Resolve_Info *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return scheme_resolve_expr(expr, info); -} - -Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) -{ - Scheme_Type type = SCHEME_TYPE(expr); - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)expr; - p->ku.k.p2 = (void *)info; - - return scheme_handle_stack_overflow(resolve_k); - } -#endif - - switch (type) { - case scheme_local_type: - { - int pos, flags; - Scheme_Object *lifted; - - pos = scheme_resolve_info_lookup(info, SCHEME_LOCAL_POS(expr), &flags, &lifted, 0); - if (lifted) { - /* Lexical reference replaced with top-level reference for a lifted value: */ - return lifted; - } else { - return scheme_make_local((flags & SCHEME_INFO_BOXED) - ? scheme_local_unbox_type - : scheme_local_type, - pos, - ((flags & SCHEME_INFO_FLONUM_ARG) - ? SCHEME_LOCAL_FLONUM - : 0)); - } - } - case scheme_application_type: - return resolve_application(expr, info, 0); - case scheme_application2_type: - return resolve_application2(expr, info, 0); - case scheme_application3_type: - return resolve_application3(expr, info, 0); - case scheme_sequence_type: - case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: - return resolve_sequence(expr, info); - case scheme_branch_type: - return resolve_branch(expr, info); - case scheme_with_cont_mark_type: - return resolve_wcm(expr, info); - case scheme_compiled_unclosed_procedure_type: - return scheme_resolve_closure_compilation(expr, info, 1, 0, 0, NULL); - case scheme_compiled_let_void_type: - return scheme_resolve_lets(expr, info); - case scheme_compiled_toplevel_type: - return scheme_resolve_toplevel(info, expr, 1); - case scheme_compiled_quote_syntax_type: - { - Scheme_Quote_Syntax *qs; - int i, c, p; - - i = SCHEME_LOCAL_POS(expr); - i = scheme_resolve_quote_syntax_offset(i, info); - c = scheme_resolve_toplevel_pos(info); - p = scheme_resolve_quote_syntax_pos(info); - - qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); - qs->so.type = scheme_quote_syntax_type; - qs->depth = c; - qs->position = i; - qs->midpoint = p; - - return (Scheme_Object *)qs; - } - case scheme_variable_type: - case scheme_module_variable_type: - scheme_signal_error("got top-level in wrong place"); - return 0; - case scheme_define_values_type: - return scheme_define_values_resolve(expr, info); - case scheme_define_syntaxes_type: - return scheme_define_syntaxes_resolve(expr, info); - case scheme_define_for_syntax_type: - return scheme_define_for_syntaxes_resolve(expr, info); - case scheme_set_bang_type: - return scheme_set_resolve(expr, info); - case scheme_require_form_type: - return scheme_top_level_require_resolve(expr, info); - case scheme_varref_form_type: - return scheme_ref_resolve(expr, info); - case scheme_apply_values_type: - return scheme_apply_values_resolve(expr, info); - case scheme_case_lambda_sequence_type: - return scheme_case_lambda_resolve(expr, info); - case scheme_module_type: - return scheme_module_expr_resolve(expr, info); - case scheme_boxenv_type: - scheme_signal_error("internal error: no boxenv resolve"); - default: - return expr; - } -} - -Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info) -{ - Scheme_Object *first = scheme_null, *last = NULL; - - while (SCHEME_PAIRP(expr)) { - Scheme_Object *pr; - - pr = scheme_make_pair(scheme_resolve_expr(SCHEME_CAR(expr), info), - scheme_null); - - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - expr = SCHEME_CDR(expr); - } - - return first; -} - -/*========================================================================*/ -/* uncompile */ -/*========================================================================*/ - -#if 0 - -/* For debugging, currently incomplete: */ - -static Scheme_Object *uncompile(int argc, Scheme_Object *argv[]); -Scheme_Object *scheme_uncompile_expr(Scheme_Object *expr, Resolve_Prefix *prefix); - -static Scheme_Object *uncompile_k() -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1; - Resolve_Prefix *prefix = (Resolve_Prefix *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return scheme_uncompile_expr(expr, prefix); -} - -Scheme_Object *scheme_uncompile_expr(Scheme_Object *expr, Resolve_Prefix *prefix) -{ - char buf[32]; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)expr; - p->ku.k.p2 = (void *)prefix; - - return scheme_handle_stack_overflow(uncompile_k); - } -#endif - - switch (SCHEME_TYPE(expr)) { - case scheme_toplevel_type: - { - expr = prefix->toplevels[SCHEME_TOPLEVEL_POS(expr)]; - if (SAME_TYPE(SCHEME_TYPE(expr), scheme_variable_type)) { - return cons(scheme_intern_symbol("#%top"), - (Scheme_Object *)((Scheme_Bucket *)expr)->key); - } else { - Module_Variable *mv = (Module_Variable *)expr; - - return cons(scheme_intern_symbol("#%top"), - cons(mv->modidx, mv->sym)); - } - } - case scheme_local_type: - { - sprintf(buf, "@%d", SCHEME_LOCAL_POS(expr)); - return scheme_intern_symbol(buf); - } - case scheme_local_unbox_type: - { - sprintf(buf, "@!%d", SCHEME_LOCAL_POS(expr)); - return scheme_intern_symbol(buf); - } - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)expr; - int i; - expr = scheme_null; - for (i = app->num_args + 1; i--; ) { - expr = cons(scheme_uncompile_expr(app->args[i], prefix), - expr); - } - return expr; - } - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; - return cons(scheme_uncompile_expr(app->rator, prefix), - cons(scheme_uncompile_expr(app->rand, prefix), - scheme_null)); - } - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; - return cons(scheme_uncompile_expr(app->rator, prefix), - cons(scheme_uncompile_expr(app->rand1, prefix), - cons(scheme_uncompile_expr(app->rand2, prefix), - scheme_null))); - } - case scheme_sequence_type: - case scheme_branch_type: - case scheme_with_cont_mark_type: - return scheme_void; - case scheme_let_value_type: - { - Scheme_Let_Value *lv = (Scheme_Let_Value *)expr; - sprintf(buf, "@%d", lv->position); - return cons(scheme_intern_symbol("let!"), - cons(scheme_make_integer(lv->count), - cons(scheme_intern_symbol(buf), - cons(scheme_uncompile_expr(lv->value, prefix), - cons(scheme_uncompile_expr(lv->body, prefix), - scheme_null))))); - } - case scheme_let_void_type: - { - Scheme_Let_Void *lv = (Scheme_Let_Void *)expr; - return cons(scheme_intern_symbol("let-undefined"), - cons(scheme_make_integer(lv->count), - cons(scheme_uncompile_expr(lv->body, prefix), - scheme_null))); - } - case scheme_letrec_type: - { - Scheme_Letrec *lr = (Scheme_Letrec *)expr; - int i; - - expr = scheme_null; - for (i = lr->count; i--; ) { - sprintf(buf, "@%d", i); - expr = cons(cons(scheme_intern_symbol(buf), - cons(scheme_uncompile_expr(lr->procs[i], prefix), - scheme_null)), - expr); - } - - return cons(scheme_intern_symbol("letrec!"), - cons(expr, - cons(scheme_uncompile_expr(lr->body, prefix), - scheme_null))); - } - case scheme_let_one_type: - { - Scheme_Let_One *lo = (Scheme_Let_One *)expr; - return cons(scheme_intern_symbol("let"), - cons(scheme_uncompile_expr(lo->value, prefix), - cons(scheme_uncompile_expr(lo->body, prefix), - scheme_null))); - } - case scheme_unclosed_procedure_type: - { - Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; - Scheme_Object *vec; - int i; - vec = scheme_make_vector(data->closure_size, NULL); - for (i = data->closure_size; i--; ) { - SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(data->closure_map[i]); - } - return cons(scheme_intern_symbol((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? "lambda*" : "lambda"), - cons(data->name ? data->name : scheme_false, - cons(scheme_make_integer(data->num_params), - cons(vec, - cons(scheme_uncompile_expr(data->code, prefix), - scheme_null))))); - } - default: - if (SCHEME_CLOSUREP(expr)) { - return scheme_uncompile_expr((Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr), prefix); - } - return cons(scheme_intern_symbol("quote"), cons(expr, scheme_null)); - } -} - -static Scheme_Object * -uncompile(int argc, Scheme_Object *argv[]) -{ - Scheme_Compilation_Top *t; - - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_compilation_top_type)) - scheme_wrong_type("compiled->datum", "compiled code", 0, argc, argv); - - t = (Scheme_Compilation_Top *)argv[0]; - - return scheme_uncompile_expr(t->code, t->prefix); -} - -#endif - -/*========================================================================*/ -/* optimize */ -/*========================================================================*/ - -static Scheme_Object *try_optimize_fold(Scheme_Object *f, Scheme_Object *o, Optimize_Info *info) -{ - if ((SCHEME_PRIMP(f) - && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) - == SCHEME_PRIM_OPT_FOLDING)) - || (SCHEME_CLSD_PRIMP(f) - && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) - == SCHEME_PRIM_OPT_FOLDING))) { - Scheme_Object *args; - - switch (SCHEME_TYPE(o)) { - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)o; - int i; - - args = scheme_null; - for (i = app->num_args; i--; ) { - args = scheme_make_pair(app->args[i + 1], args); - } - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; - args = scheme_make_pair(app->rand, scheme_null); - } - break; - case scheme_application3_type: - default: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; - args = scheme_make_pair(app->rand1, - scheme_make_pair(app->rand2, - scheme_null)); - } - break; - } - - return try_apply(f, args, info->context); - } - - return NULL; -} - -static int estimate_expr_size(Scheme_Object *expr, int sz, int fuel) -{ - Scheme_Type t; - - if (sz > 128) - return sz; - if (fuel < 0) - return sz + 128; - - t = SCHEME_TYPE(expr); - - switch(t) { - case scheme_local_type: - { - sz += 1; - break; - } - case scheme_case_lambda_sequence_type: - { - int max_sz = sz + 1, a_sz; - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr; - int i; - for (i = cl->count; i--; ) { - a_sz = estimate_expr_size(cl->array[i], sz, fuel); - if (a_sz > max_sz) max_sz = a_sz; - } - sz = max_sz; - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; - - sz = estimate_expr_size(app->rator, sz, fuel - 1); - sz = estimate_expr_size(app->rand, sz, fuel - 1); - sz++; - - break; - } - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)expr; - int i; - - for (i = app->num_args + 1; i--; ) { - sz = estimate_expr_size(app->args[i], sz, fuel - 1); - } - sz++; - - break; - } - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; - - sz = estimate_expr_size(app->rator, sz, fuel - 1); - sz = estimate_expr_size(app->rand1, sz, fuel - 1); - sz = estimate_expr_size(app->rand2, sz, fuel - 1); - sz++; - - break; - } - case scheme_compiled_let_void_type: - { - Scheme_Let_Header *head = (Scheme_Let_Header *)expr; - Scheme_Object *body; - Scheme_Compiled_Let_Value *lv; - int i; - - body = head->body; - for (i = head->num_clauses; i--; ) { - lv = (Scheme_Compiled_Let_Value *)body; - sz = estimate_expr_size(lv->value, sz, fuel - 1); - body = lv->body; - sz++; - } - sz = estimate_expr_size(body, sz, fuel - 1); - break; - } - case scheme_sequence_type: - case scheme_begin0_sequence_type: - { - Scheme_Sequence *seq = (Scheme_Sequence *)expr; - int i; - - for (i = seq->count; i--; ) { - sz = estimate_expr_size(seq->array[i], sz, fuel - 1); - } - - break; - } - case scheme_branch_type: - { - Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr; - - sz = estimate_expr_size(b->test, sz, fuel - 1); - sz = estimate_expr_size(b->tbranch, sz, fuel - 1); - sz = estimate_expr_size(b->fbranch, sz, fuel - 1); - break; - } - case scheme_compiled_unclosed_procedure_type: - { - sz = estimate_expr_size(((Scheme_Closure_Data *)expr)->code, sz, fuel - 1); - sz++; - break; - } - case scheme_compiled_toplevel_type: - case scheme_compiled_quote_syntax_type: - /* FIXME: other syntax types not covered */ - default: - sz += 1; - break; - } - - return sz; -} - -Scheme_Object *scheme_estimate_closure_size(Scheme_Object *e) -{ - int sz; - sz = estimate_expr_size(e, 0, 32); - return scheme_box(scheme_make_integer(sz)); -} - -Scheme_Object *scheme_no_potential_size(Scheme_Object *v) -{ - if (v && SCHEME_BOXP(v)) - return NULL; - else - return v; -} - -static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info, - int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, - int context, - int nested_count, Scheme_Object *orig, Scheme_Object *le_prev, intptr_t prev_offset) -{ - Scheme_Let_Header *lh; - Scheme_Compiled_Let_Value *lv, *prev = NULL; - Scheme_Object *val; - int i, expected; - int *flags, flag; - Optimize_Info *sub_info; - - expected = data->num_params; - - if (!expected) { - info = scheme_optimize_info_add_frame(info, 0, 0, 0); - info->inline_fuel >>= 1; - p = scheme_optimize_expr(p, info, context); - info->next->single_result = info->single_result; - info->next->preserves_marks = info->preserves_marks; - scheme_optimize_info_done(info); - - if (le_prev) { - *((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p; - return orig; - } else - return p; - } - - lh = MALLOC_ONE_TAGGED(Scheme_Let_Header); - lh->iso.so.type = scheme_compiled_let_void_type; - lh->count = expected; - lh->num_clauses = expected; - - for (i = 0; i < expected; i++) { - lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - lv->iso.so.type = scheme_compiled_let_value_type; - lv->count = 1; - lv->position = i; - - if ((i == expected - 1) - && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) { - int j; - Scheme_Object *l = scheme_null; - - for (j = argc; j-- > i; ) { - if (app) - val = app->args[j + 1]; - else if (app3) - val = (j ? app3->rand2 : app3->rand1); - else if (app2) - val = app2->rand; - else - val = scheme_false; - - l = cons(val, l); - } - l = cons(scheme_list_proc, l); - val = make_application(l); - } else if (app) - val = app->args[i + 1]; - else if (app3) - val = (i ? app3->rand2 : app3->rand1); - else - val = app2->rand; - - if (nested_count) - val = scheme_optimize_shift(val, nested_count, 0); - lv->value = val; - - flag = scheme_closure_argument_flags(data, i); - flags = (int *)scheme_malloc_atomic(sizeof(int)); - flags[0] = flag; - lv->flags = flags; - - if (prev) - prev->body = (Scheme_Object *)lv; - else - lh->body = (Scheme_Object *)lv; - prev = lv; - } - - if (prev) - prev->body = p; - else - lh->body = p; - - sub_info = scheme_optimize_info_add_frame(info, 0, 0, 0); - sub_info->inline_fuel >>= 1; - - p = scheme_optimize_lets((Scheme_Object *)lh, sub_info, 1, context); - - info->single_result = sub_info->single_result; - info->preserves_marks = sub_info->preserves_marks; - scheme_optimize_info_done(sub_info); - - if (le_prev) { - *((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p; - return orig; - } else - return p; -} - -#if 0 -# define LOG_INLINE(x) x -#else -# define LOG_INLINE(x) /*empty*/ -#endif - -Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc, - Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, - int *_flags, int context, int optimized_rator) -/* If not app, app2, or app3, just return a known procedure, if any, - and do not check arity. */ -{ - int offset = 0, single_use = 0, psize = 0; - Scheme_Object *bad_app = NULL, *prev = NULL, *orig_le = le; - intptr_t prev_offset = 0; - int nested_count = 0, outside_nested = 0, already_opt = optimized_rator; - - if (info->inline_fuel < 0) - return NULL; - - /* Move inside `let' bindings, so we can convert ((let (....) proc) arg ...) - to (let (....) (proc arg ...)) */ - while (optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_let_void_type)) { - Scheme_Let_Header *lh; - int i; - - lh = (Scheme_Let_Header *)le; - prev = le; - prev_offset = (intptr_t)&(((Scheme_Let_Header *)0x0)->body); - le = lh->body; - for (i = 0; i < lh->num_clauses; i++) { - prev = le; - prev_offset = (intptr_t)&(((Scheme_Compiled_Let_Value *)0x0)->body); - le = ((Scheme_Compiled_Let_Value *)le)->body; - } - nested_count += lh->count; - } - - if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { - /* Found a `((lambda' */ - single_use = 1; - } - - if (!optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) { - /* Check for inlining: */ - le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use, 0, 0, &psize); - outside_nested = 1; - already_opt = 1; - } - - if (le) { - while (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_toplevel_type)) { - single_use = 0; - if (info->top_level_consts) { - int pos; - pos = SCHEME_TOPLEVEL_POS(le); - le = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - if (le && SCHEME_BOXP(le)) { - psize = SCHEME_INT_VAL(SCHEME_BOX_VAL(le)); - le = NULL; - } - if (!le) - break; - outside_nested = 1; - already_opt = 1; - } else - break; - } - } - - if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_case_lambda_sequence_type)) { - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)le; - Scheme_Object *cp; - int i, count; - - if (!app && !app2 && !app3) - return le; - - count = cl->count; - for (i = 0; i < count; i++) { - cp = cl->array[i]; - if (SAME_TYPE(SCHEME_TYPE(cp), scheme_compiled_unclosed_procedure_type)) { - Scheme_Closure_Data *data = (Scheme_Closure_Data *)cp; - if ((data->num_params == argc) - || ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - && (argc + 1 >= data->num_params))) { - le = cp; - break; - } - } else { - scheme_signal_error("internal error: strange case-lambda"); - } - } - if (i >= count) - bad_app = le; - } - - if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { - Scheme_Closure_Data *data = (Scheme_Closure_Data *)le; - int sz; - - if (!app && !app2 && !app3) - return le; - - *_flags = SCHEME_CLOSURE_DATA_FLAGS(data); - - if ((data->num_params == argc) - || ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - && (argc + 1 >= data->num_params)) - || (!app && !app2 && !app3)) { - int threshold, is_leaf; - - if (!already_opt) { - /* We have an immediate `lambda' that wasn't optimized, yet. - Go optimize it, first. */ - return NULL; - } - - sz = scheme_closure_body_size(data, 1, info, &is_leaf); - if (is_leaf) { - /* encourage inlining of leaves: */ - sz >>= 2; - } - threshold = info->inline_fuel * (2 + argc); - - if ((sz >= 0) && (single_use || (sz <= threshold))) { - Optimize_Info *sub_info; - if (nested_count) { - sub_info = scheme_optimize_info_add_frame(info, nested_count, nested_count, 0); - sub_info->vclock++; - /* We could propagate bound values in sub_info, but relevant inlining - and propagatation has probably already happened when the rator was - optimized. */ - } else - sub_info = info; - le = scheme_optimize_clone(0, data->code, sub_info, - offset + (outside_nested ? nested_count : 0), - data->num_params); - - if (le) { - LOG_INLINE(fprintf(stderr, "Inline %d[%d]<=%d@%d %d %s\n", sz, is_leaf, threshold, info->inline_fuel, - single_use, data->name ? scheme_write_to_string(data->name, NULL) : "???")); - le = apply_inlined(le, data, sub_info, argc, app, app2, app3, context, - nested_count, orig_le, prev, prev_offset); - if (nested_count) - scheme_optimize_info_done(sub_info); - return le; - } else { - LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???")); - info->has_nonleaf = 1; - } - } else { - LOG_INLINE(fprintf(stderr, "No fuel %s %d[%d]>%d@%d %d\n", data->name ? scheme_write_to_string(data->name, NULL) : "???", - sz, is_leaf, threshold, - info->inline_fuel, info->use_psize)); - info->has_nonleaf = 1; - } - } else { - /* Issue warning below */ - bad_app = (Scheme_Object *)data; - } - } - - if (le && SCHEME_PRIMP(le)) { - int opt; - opt = ((Scheme_Prim_Proc_Header *)le)->flags & SCHEME_PRIM_OPT_MASK; - if (opt >= SCHEME_PRIM_OPT_NONCM) - *_flags = (CLOS_PRESERVES_MARKS | CLOS_SINGLE_RESULT); - } - - if (le && SCHEME_PROCP(le) && (app || app2 || app3)) { - Scheme_Object *a[1]; - a[0] = le; - if (!scheme_check_proc_arity(NULL, argc, 0, 1, a)) { - bad_app = le; - } - } - - if (psize) { - LOG_INLINE(fprintf(stderr, "Potential inline %d %d\n", psize, info->inline_fuel * (argc + 2))); - if (psize <= (info->inline_fuel * (argc + 2))) - info->psize += psize; - } - - if (!le) - info->has_nonleaf = 1; - - if (bad_app) { - int len; - const char *pname, *context; - pname = scheme_get_proc_name(bad_app, &len, 0); - context = scheme_optimize_context_to_string(info->context); - scheme_log(NULL, - SCHEME_LOG_WARNING, - 0, - "warning%s: optimizer detects procedure incorrectly applied to %d arguments%s%s", - context, - argc, - pname ? ": " : "", - pname ? pname : ""); - } - - return NULL; -} - -int scheme_is_flonum_expression(Scheme_Object *expr, Optimize_Info *info) -{ - if (scheme_expr_produces_flonum(expr)) - return 1; - - if (SAME_TYPE(SCHEME_TYPE(expr), scheme_local_type)) { - if (scheme_optimize_is_flonum_valued(info, SCHEME_LOCAL_POS(expr))) - return 1; - } - - return 0; -} - -static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, - Optimize_Info *info) -{ - Scheme_Object *rator, *rand, *le; - int n, i; - - if (app) { - rator = app->args[0]; - n = app->num_args; - } else if (app2) { - rator = app2->rator; - n = 1; - } else { - rator = app3->rator; - n = 2; - } - - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) { - rator = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rator), 1); - if (rator) { - int offset, single_use; - le = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(rator), &offset, &single_use, 0, 0, NULL); - if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { - Scheme_Closure_Data *data = (Scheme_Closure_Data *)le; - char *map; - int ok; - - map = scheme_get_closure_flonum_map(data, n, &ok); - - if (ok) { - for (i = 0; i < n; i++) { - int is_flonum; - - if (app) - rand = app->args[i+1]; - else if (app2) - rand = app2->rand; - else { - if (!i) - rand = app3->rand1; - else - rand = app3->rand2; - } - - is_flonum = scheme_is_flonum_expression(rand, info); - if (is_flonum) { - if (!map) { - map = MALLOC_N_ATOMIC(char, n); - memset(map, 1, n); - memset(map, 0, i); - } - } - if (map && !is_flonum) - map[i] = 0; - } - - scheme_set_closure_flonum_map(data, map); - } - } - } - } -} - -char *scheme_optimize_context_to_string(Scheme_Object *context) -{ - if (context) { - Scheme_Object *mod, *func; - const char *ctx, *prefix, *mctx, *mprefix; - char *all; - int clen, plen, mclen, mplen, len; - - if (SCHEME_PAIRP(context)) { - func = SCHEME_CAR(context); - mod = SCHEME_CDR(context); - } else if (SAME_TYPE(SCHEME_TYPE(context), scheme_module_type)) { - func = scheme_false; - mod = context; - } else { - func = context; - mod = scheme_false; - } - - if (SAME_TYPE(SCHEME_TYPE(func), scheme_compiled_unclosed_procedure_type)) { - Scheme_Object *name; - - name = ((Scheme_Closure_Data *)func)->name; - if (name) { - if (SCHEME_VECTORP(name)) { - Scheme_Object *port; - int print_width = 1024; - intptr_t plen; - - port = scheme_make_byte_string_output_port(); - - scheme_write_proc_context(port, print_width, - SCHEME_VEC_ELS(name)[0], - SCHEME_VEC_ELS(name)[1], SCHEME_VEC_ELS(name)[2], - SCHEME_VEC_ELS(name)[3], SCHEME_VEC_ELS(name)[4], - SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6])); - - ctx = scheme_get_sized_byte_string_output(port, &plen); - prefix = " in: "; - } else { - ctx = scheme_get_proc_name(func, &len, 0); - prefix = " in: "; - } - } else { - ctx = ""; - prefix = ""; - } - } else { - ctx = ""; - prefix = ""; - } - - if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) { - mctx = scheme_display_to_string(((Scheme_Module *)mod)->modsrc, NULL); - mprefix = " in module: "; - } else { - mctx = ""; - mprefix = ""; - } - - clen = strlen(ctx); - plen = strlen(prefix); - mclen = strlen(mctx); - mplen = strlen(mprefix); - - if (!clen && !mclen) - return ""; - - all = scheme_malloc_atomic(clen + plen + mclen + mplen + 1); - memcpy(all, prefix, plen); - memcpy(all + plen, ctx, clen); - memcpy(all + plen + clen, mprefix, mplen); - memcpy(all + plen + clen + mplen, mctx, mclen); - all[clen + plen + mclen + mplen] = 0; - return all; - } else - return ""; -} - -static void reset_rator(Scheme_Object *app, Scheme_Object *a) -{ - switch (SCHEME_TYPE(app)) { - case scheme_application_type: - ((Scheme_App_Rec *)app)->args[0] = a; - break; - case scheme_application2_type: - ((Scheme_App2_Rec *)app)->rator = a; - break; - case scheme_application3_type: - ((Scheme_App3_Rec *)app)->rator = a; - break; - } -} - -static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rator, Optimize_Info *info, - int argc, int context) -{ - /* Convert ((let (....) E) arg ...) to (let (....) (E arg ...)), in case - the `let' is immediately apparent. We check for this pattern again - in optimize_for_inline() after optimizing a rator. */ - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_let_void_type)) { - Scheme_Let_Header *head = (Scheme_Let_Header *)rator; - Scheme_Compiled_Let_Value *clv; - int i; - - /* Handle ((let ([f ...]) f) arg ...) specially, so we can - adjust the flags for `f': */ - if ((head->count == 1) && (head->num_clauses == 1)) { - clv = (Scheme_Compiled_Let_Value *)head->body; - rator = clv->body; - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type) - && (SCHEME_LOCAL_POS(rator) == 0) - && scheme_is_compiled_procedure(clv->value, 1, 1)) { - - reset_rator(app, scheme_false); - app = scheme_optimize_shift(app, 1, 0); - reset_rator(app, scheme_make_local(scheme_local_type, 0, 0)); - - clv->body = app; - - if (clv->flags[0] & SCHEME_WAS_APPLIED_EXCEPT_ONCE) { - clv->flags[0] -= SCHEME_WAS_APPLIED_EXCEPT_ONCE; - clv->flags[0] |= SCHEME_WAS_ONLY_APPLIED; - } - - return scheme_optimize_expr((Scheme_Object *)head, info, context); - } - } - - clv = NULL; - rator = head->body; - for (i = head->num_clauses; i--; ) { - clv = (Scheme_Compiled_Let_Value *)rator; - rator = clv->body; - } - - reset_rator(app, scheme_false); - app = scheme_optimize_shift(app, head->count, 0); - reset_rator(app, rator); - - if (clv) - clv->body = app; - else - head->body = app; - - return scheme_optimize_expr((Scheme_Object *)head, info, context); - } - - return NULL; -} - -static int purely_functional_primitive(Scheme_Object *rator, int n) -{ - if (SCHEME_PRIMP(rator) - && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) - && (n >= ((Scheme_Primitive_Proc *)rator)->mina) - && (n <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)) - return 1; - - if (SAME_OBJ(scheme_void_proc, rator) - || SAME_OBJ(scheme_list_proc, rator) - || (SAME_OBJ(scheme_cons_proc, rator) && (n == 2)) - || SAME_OBJ(scheme_list_star_proc, rator) - || SAME_OBJ(scheme_vector_proc, rator) - || SAME_OBJ(scheme_vector_immutable_proc, rator) - || (SAME_OBJ(scheme_box_proc, rator) && (n == 1))) - return 1; - - return 0; -} - -#define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm)) - -int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_mode) -/* In rotate mode, we really want to know whether any argument wants to be lifted out. */ -{ - if (SCHEME_PRIMP(rator)) { - if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) { - if (IS_NAMED_PRIM(rator, "unsafe-flabs") - || IS_NAMED_PRIM(rator, "unsafe-flsqrt") - || IS_NAMED_PRIM(rator, "unsafe-fl+") - || IS_NAMED_PRIM(rator, "unsafe-fl-") - || IS_NAMED_PRIM(rator, "unsafe-fl*") - || IS_NAMED_PRIM(rator, "unsafe-fl/") - || IS_NAMED_PRIM(rator, "unsafe-fl<") - || IS_NAMED_PRIM(rator, "unsafe-fl<=") - || IS_NAMED_PRIM(rator, "unsafe-fl=") - || IS_NAMED_PRIM(rator, "unsafe-fl>") - || IS_NAMED_PRIM(rator, "unsafe-fl>=") - || IS_NAMED_PRIM(rator, "unsafe-flmin") - || IS_NAMED_PRIM(rator, "unsafe-flmax") - || (!rotate_mode && IS_NAMED_PRIM(rator, "unsafe-fl->fx")) - || (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) - || (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) - return 1; - } else if (SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { - if (!rotate_mode) { - if (IS_NAMED_PRIM(rator, "flabs") - || IS_NAMED_PRIM(rator, "flsqrt") - || IS_NAMED_PRIM(rator, "fltruncate") - || IS_NAMED_PRIM(rator, "flround") - || IS_NAMED_PRIM(rator, "flfloor") - || IS_NAMED_PRIM(rator, "flceiling") - || IS_NAMED_PRIM(rator, "flsin") - || IS_NAMED_PRIM(rator, "flcos") - || IS_NAMED_PRIM(rator, "fltan") - || IS_NAMED_PRIM(rator, "flasin") - || IS_NAMED_PRIM(rator, "flacos") - || IS_NAMED_PRIM(rator, "flatan") - || IS_NAMED_PRIM(rator, "fllog") - || IS_NAMED_PRIM(rator, "flexp") - || IS_NAMED_PRIM(rator, "fl+") - || IS_NAMED_PRIM(rator, "fl-") - || IS_NAMED_PRIM(rator, "fl*") - || IS_NAMED_PRIM(rator, "fl/") - || IS_NAMED_PRIM(rator, "fl<") - || IS_NAMED_PRIM(rator, "fl<=") - || IS_NAMED_PRIM(rator, "fl=") - || IS_NAMED_PRIM(rator, "fl>") - || IS_NAMED_PRIM(rator, "flmin") - || IS_NAMED_PRIM(rator, "flmax")) - return 1; - } - if ((rotate_mode || (argpos == 2)) - && IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) - return 1; - if (!rotate_mode && (argpos == 2) - && IS_NAMED_PRIM(rator, "flvector-set!")) - return 1; - } - } - - return 0; -} - -static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc, int for_args) -{ - if (SCHEME_PRIMP(rator)) { - if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) { - if (((argc == 1) - && (IS_NAMED_PRIM(rator, "unsafe-flabs") - || IS_NAMED_PRIM(rator, "unsafe-flsqrt") - || IS_NAMED_PRIM(rator, "unsafe-flreal-part") - || IS_NAMED_PRIM(rator, "unsafe-flimag-part"))) - || ((argc == 2) - && (IS_NAMED_PRIM(rator, "unsafe-fl+") - || IS_NAMED_PRIM(rator, "unsafe-fl-") - || IS_NAMED_PRIM(rator, "unsafe-fl*") - || IS_NAMED_PRIM(rator, "unsafe-fl/") - || IS_NAMED_PRIM(rator, "unsafe-flmin") - || IS_NAMED_PRIM(rator, "unsafe-flmax") - || (for_args - && (IS_NAMED_PRIM(rator, "unsafe-fl<") - || IS_NAMED_PRIM(rator, "unsafe-fl<=") - || IS_NAMED_PRIM(rator, "unsafe-fl=") - || IS_NAMED_PRIM(rator, "unsafe-fl>") - || IS_NAMED_PRIM(rator, "unsafe-fl>=")))))) - return 1; - if (((argc == 2) && IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) - || ((argc == 1) && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) { - if (non_fl_args) *non_fl_args = 1; - return 1; - } - } else if ((argc == 1) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { - if (IS_NAMED_PRIM(rator, "flabs") - || IS_NAMED_PRIM(rator, "flsqrt") - || IS_NAMED_PRIM(rator, "fltruncate") - || IS_NAMED_PRIM(rator, "flround") - || IS_NAMED_PRIM(rator, "flfloor") - || IS_NAMED_PRIM(rator, "flceiling") - || IS_NAMED_PRIM(rator, "flsin") - || IS_NAMED_PRIM(rator, "flcos") - || IS_NAMED_PRIM(rator, "fltan") - || IS_NAMED_PRIM(rator, "flasin") - || IS_NAMED_PRIM(rator, "flacos") - || IS_NAMED_PRIM(rator, "flatan") - || IS_NAMED_PRIM(rator, "fllog") - || IS_NAMED_PRIM(rator, "flexp") - || IS_NAMED_PRIM(rator, "flimag-part") - || IS_NAMED_PRIM(rator, "flreal-part")) - return 1; - if (IS_NAMED_PRIM(rator, "->fl")) { - if (non_fl_args) *non_fl_args = 1; - return 1; - } - } else if ((argc ==2) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { - if (IS_NAMED_PRIM(rator, "flabs") - || IS_NAMED_PRIM(rator, "flsqrt") - || IS_NAMED_PRIM(rator, "fl+") - || IS_NAMED_PRIM(rator, "fl-") - || IS_NAMED_PRIM(rator, "fl*") - || IS_NAMED_PRIM(rator, "fl/") - || IS_NAMED_PRIM(rator, "flmin") - || IS_NAMED_PRIM(rator, "flmax") - || (for_args - && (IS_NAMED_PRIM(rator, "fl<") - || IS_NAMED_PRIM(rator, "fl<=") - || IS_NAMED_PRIM(rator, "fl=") - || IS_NAMED_PRIM(rator, "fl>") - || IS_NAMED_PRIM(rator, "fl>=")))) - return 1; - if (IS_NAMED_PRIM(rator, "flvector-ref")) { - if (non_fl_args) *non_fl_args = 1; - return 1; - } - } - } - - return 0; -} - -static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *info, int lifted) -{ - if (fuel > 0) { - switch (SCHEME_TYPE(rand)) { - case scheme_local_type: - { - /* Ok if not mutable */ - int pos = SCHEME_LOCAL_POS(rand); - if (pos < lifted) - return 1; - else if (!scheme_optimize_is_mutated(info, pos - lifted)) - return 1; - } - break; - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)rand; - int non_fl_args = 0; - if (produces_unboxed(app->args[0], &non_fl_args, app->num_args, 1)) { - int i; - for (i = app->num_args; i--; ) { - fuel--; - if (!is_unboxed_argument(app->args[i+1], fuel, info, lifted)) - return 0; - } - return 1; - } - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)rand; - int non_fl_args = 0; - if (produces_unboxed(app->rator, &non_fl_args, 1, 1)) { - if (is_unboxed_argument(app->rand, fuel - 1, info, lifted)) - return 1; - } - } - break; - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)rand; - int non_fl_args = 0; - if (produces_unboxed(app->rator, &non_fl_args, 2, 1)) { - if (is_unboxed_argument(app->rand1, fuel - 1, info, lifted) - && is_unboxed_argument(app->rand2, fuel - 2, info, lifted)) - return 1; - } - } - break; - default: - if (SCHEME_TYPE(rand) > _scheme_compiled_values_types_) - return 1; - break; - } - } - - return 0; -} - -int scheme_expr_produces_flonum(Scheme_Object *expr) -{ - while (1) { - switch (SCHEME_TYPE(expr)) { - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)expr; - return produces_unboxed(app->args[0], NULL, app->num_args, 0); - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; - return produces_unboxed(app->rator, NULL, 1, 0); - } - break; - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; - return produces_unboxed(app->rator, NULL, 2, 0); - } - break; - case scheme_compiled_let_void_type: - { - Scheme_Let_Header *lh = (Scheme_Let_Header *)expr; - int i; - expr = lh->body; - for (i = 0; i < lh->num_clauses; i++) { - expr = ((Scheme_Compiled_Let_Value *)expr)->body; - } - /* check expr again */ - } - break; - default: - if (SCHEME_FLOATP(expr)) - return 1; - return 0; - } - } -} - -static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *rator, int count, Optimize_Info *info) -{ - Scheme_Object *result = _app, *rand, *new_rand; - Scheme_Let_Header *inner_head = NULL; - Scheme_Compiled_Let_Value *inner = NULL; - int i, lifted = 0; - - if (scheme_wants_flonum_arguments(rator, 0, 1)) { - for (i = 0; i < count; i++) { - if (count == 1) - rand = ((Scheme_App2_Rec *)_app)->rand; - else if (count == 2) { - if (i == 0) - rand = ((Scheme_App3_Rec *)_app)->rand1; - else - rand = ((Scheme_App3_Rec *)_app)->rand2; - } else - rand = ((Scheme_App_Rec *)_app)->args[i + 1]; - - if (!is_unboxed_argument(rand, 32, info, lifted)) { - int delta; - - if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_let_void_type)) { - /* Rotate ( (let* ([x ]...) )) - to (let* ([x ]...) ( )) */ - Scheme_Let_Header *top_head = (Scheme_Let_Header *)rand, *head; - Scheme_Compiled_Let_Value *clv, *prev; - Scheme_Object *e; - int i; - - top_head = head = (Scheme_Let_Header *)rand; - prev = NULL; - e = rand; - delta = 0; - while (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_let_void_type)) { - head = (Scheme_Let_Header *)e; - delta += head->count; - prev = NULL; - - clv = (Scheme_Compiled_Let_Value *)head->body; - prev = NULL; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - prev = clv; - } - e = (Scheme_Object *)clv; - } - - if (prev) - new_rand = prev->body; - else - new_rand = head->body; - - if (inner) - inner->body = (Scheme_Object *)top_head; - else if (inner_head) - inner_head->body = (Scheme_Object *)top_head; - else - result = (Scheme_Object *)top_head; - - inner = prev; - inner_head = head; - } else { - /* Rotate ( ) to - (let ([x ]) ( x)) */ - Scheme_Let_Header *head; - Scheme_Compiled_Let_Value *lv; - int *flags; - - head = MALLOC_ONE_TAGGED(Scheme_Let_Header); - head->iso.so.type = scheme_compiled_let_void_type; - head->count = 1; - head->num_clauses = 1; - - lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - lv->iso.so.type = scheme_compiled_let_value_type; - lv->count = 1; - lv->position = 0; - lv->value = rand; - - flags = (int *)scheme_malloc_atomic(sizeof(int)); - flags[0] = (SCHEME_WAS_USED | (1 << SCHEME_USE_COUNT_SHIFT)); - if (scheme_wants_flonum_arguments(rator, i, 0)) - flags[0] |= SCHEME_WAS_FLONUM_ARGUMENT; - lv->flags = flags; - - head->body = (Scheme_Object *)lv; - - new_rand = scheme_make_local(scheme_local_type, 0, 0); - - if (inner) - inner->body = (Scheme_Object *)head; - else if (inner_head) - inner_head->body = (Scheme_Object *)head; - else - result = (Scheme_Object *)head; - - inner = lv; - inner_head = head; - - delta = 1; - } - - if (delta) { - lifted += delta; - if (count == 1) - ((Scheme_App2_Rec *)_app)->rand = scheme_false; - else if (count == 2) { - if (i == 0) - ((Scheme_App3_Rec *)_app)->rand1 = scheme_false; - else - ((Scheme_App3_Rec *)_app)->rand2 = scheme_false; - } else - ((Scheme_App_Rec *)_app)->args[i + 1] = scheme_false; - - _app = scheme_optimize_shift(_app, delta, 0); - } - - if (count == 1) - ((Scheme_App2_Rec *)_app)->rand = new_rand; - else if (count == 2) { - if (i == 0) - ((Scheme_App3_Rec *)_app)->rand1 = new_rand; - else - ((Scheme_App3_Rec *)_app)->rand2 = new_rand; - } else - ((Scheme_App_Rec *)_app)->args[i + 1] = new_rand; - - if (inner) - inner->body = _app; - else - inner_head->body = _app; - } - } - } - - return result; -} - -static Scheme_Object *finish_optimize_app(Scheme_Object *o, Optimize_Info *info, int context, int rator_flags) -{ - switch(SCHEME_TYPE(o)) { - case scheme_application_type: - return finish_optimize_application((Scheme_App_Rec *)o, info, context, rator_flags); - case scheme_application2_type: - return finish_optimize_application2((Scheme_App2_Rec *)o, info, context, rator_flags); - case scheme_application3_type: - return finish_optimize_application3((Scheme_App3_Rec *)o, info, context, rator_flags); - default: - return o; /* may be a constant due to constant-folding */ - } -} - -static Scheme_Object *direct_apply(Scheme_Object *expr, Scheme_Object *rator, Scheme_Object *last_rand) -{ - if (SAME_OBJ(rator, scheme_apply_proc)) { - switch(SCHEME_TYPE(last_rand)) { - case scheme_application_type: - rator = ((Scheme_App_Rec *)last_rand)->args[0]; - break; - case scheme_application2_type: - rator = ((Scheme_App2_Rec *)last_rand)->rator; - break; - case scheme_application3_type: - rator = ((Scheme_App3_Rec *)last_rand)->rator; - break; - case scheme_pair_type: - if (scheme_is_list(last_rand)) - rator = scheme_list_proc; - else - rator = NULL; - break; - case scheme_null_type: - rator = scheme_list_proc; - break; - default: - rator = NULL; - break; - } - - if (rator && SAME_OBJ(rator, scheme_list_proc)) { - /* Convert (apply f arg1 ... (list arg2 ...)) - to (f arg1 ... arg2 ...) */ - Scheme_Object *l = scheme_null; - int i; - - switch(SCHEME_TYPE(last_rand)) { - case scheme_application_type: - for (i = ((Scheme_App_Rec *)last_rand)->num_args; i--; ) { - l = scheme_make_pair(((Scheme_App_Rec *)last_rand)->args[i+1], l); - } - break; - case scheme_application2_type: - l = scheme_make_pair(((Scheme_App2_Rec *)last_rand)->rand, l); - break; - case scheme_application3_type: - l = scheme_make_pair(((Scheme_App3_Rec *)last_rand)->rand2, l); - l = scheme_make_pair(((Scheme_App3_Rec *)last_rand)->rand1, l); - break; - case scheme_pair_type: - l = last_rand; - break; - case scheme_null_type: - l = scheme_null; - break; - } - - switch(SCHEME_TYPE(expr)) { - case scheme_application_type: - for (i = ((Scheme_App_Rec *)expr)->num_args - 1; i--; ) { - l = scheme_make_pair(((Scheme_App_Rec *)expr)->args[i+1], l); - } - break; - default: - case scheme_application3_type: - l = scheme_make_pair(((Scheme_App3_Rec *)expr)->rand1, l); - break; - } - - return make_application(l); - } - } - - return NULL; -} - -static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info, int context) -{ - Scheme_Object *le; - Scheme_App_Rec *app; - int i, n, rator_flags = 0, sub_context = 0; - - app = (Scheme_App_Rec *)o; - - /* Check for (apply ... (list ...)) early: */ - le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args]); - if (le) return scheme_optimize_expr(le, info, context); - - le = check_app_let_rator(o, app->args[0], info, app->num_args, context); - if (le) return le; - - n = app->num_args + 1; - - for (i = 0; i < n; i++) { - if (!i) { - le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 0); - if (le) - return le; - } - - sub_context = 0; - if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1, 0)) - sub_context = OPT_CONTEXT_FLONUM_ARG; - - le = scheme_optimize_expr(app->args[i], info, sub_context); - app->args[i] = le; - - if (!i) { - /* Maybe found "((lambda" after optimizing; try again */ - le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 1); - if (le) - return le; - } - } - - /* Check for (apply ... (list ...)) after some optimizations: */ - le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args]); - if (le) return finish_optimize_app(le, info, context, rator_flags); - - return finish_optimize_application(app, info, context, rator_flags); -} - -static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_Info *info, int context, int rator_flags) -{ - Scheme_Object *le; - int all_vals = 1, i; - - for (i = app->num_args; i--; ) { - if (SCHEME_TYPE(app->args[i+1]) < _scheme_compiled_values_types_) - all_vals = 0; - } - - info->size += 1; - if (!purely_functional_primitive(app->args[0], app->num_args)) - info->vclock += 1; - - if (all_vals) { - le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info); - if (le) - return le; - } - - info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); - info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); - if (rator_flags & CLOS_RESULT_TENTATIVE) { - info->preserves_marks = -info->preserves_marks; - info->single_result = -info->single_result; - } - - if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc)) - return scheme_null; - - register_flonum_argument_types(app, NULL, NULL, info); - - return check_unbox_rotation((Scheme_Object *)app, app->args[0], app->num_args, info); -} - -static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *rand) -{ - Scheme_Object *c = NULL; - - if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rand))) - c = rand; - if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) { - int offset; - Scheme_Object *expr; - expr = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0); - c = scheme_optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL, 0, 0, NULL); - } - if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) { - if (info->top_level_consts) { - int pos; - - while (1) { - pos = SCHEME_TOPLEVEL_POS(rand); - c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - c = scheme_no_potential_size(c); - if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type)) - rand = c; - else - break; - } - } - } - - if (c && SAME_TYPE(scheme_noninline_proc_type, SCHEME_TYPE(c))) { - c = SCHEME_BOX_VAL(c); - - while (SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_let_void_type)) { - /* This must be (let ([x ]) ); see scheme_is_statically_proc() */ - Scheme_Let_Header *lh = (Scheme_Let_Header *)c; - Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - c = lv->body; - } - } - - if (c && (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c)) - || SAME_TYPE(scheme_case_lambda_sequence_type, SCHEME_TYPE(c)))) - return c; - - return NULL; -} - -static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info, int context) -{ - Scheme_App2_Rec *app; - Scheme_Object *le; - int rator_flags = 0, sub_context = 0; - - app = (Scheme_App2_Rec *)o; - - le = check_app_let_rator(o, app->rator, info, 1, context); - if (le) return le; - - le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 0); - if (le) - return le; - - le = scheme_optimize_expr(app->rator, info, sub_context); - app->rator = le; - - { - /* Maybe found "((lambda" after optimizing; try again */ - le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 1); - if (le) - return le; - } - - if (scheme_wants_flonum_arguments(app->rator, 0, 0)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; - - le = scheme_optimize_expr(app->rand, info, sub_context); - app->rand = le; - - return finish_optimize_application2(app, info, context, rator_flags); -} - -static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags) -{ - Scheme_Object *le; - - info->size += 1; - - if (SCHEME_TYPE(app->rand) > _scheme_compiled_values_types_) { - le = try_optimize_fold(app->rator, (Scheme_Object *)app, info); - if (le) - return le; - } - - if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) { - if (lookup_constant_proc(info, app->rand)) { - info->preserves_marks = 1; - info->single_result = 1; - return scheme_true; - } - } - - if ((SAME_OBJ(scheme_values_func, app->rator) - || SAME_OBJ(scheme_list_star_proc, app->rator)) - && (scheme_omittable_expr(app->rand, 1, -1, 0, info, -1) - || single_valued_noncm_expression(app->rand, 5))) { - info->preserves_marks = 1; - info->single_result = 1; - return app->rand; - } - - if (!purely_functional_primitive(app->rator, 1)) - info->vclock += 1; - - info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); - info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); - if (rator_flags & CLOS_RESULT_TENTATIVE) { - info->preserves_marks = -info->preserves_marks; - info->single_result = -info->single_result; - } - - /* Check for things like (cXr (cons X Y)): */ - if (SCHEME_PRIMP(app->rator) - && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) { - Scheme_Object *rand, *inside = NULL, *alt = NULL; - - rand = app->rand; - - /* We can go inside a `let', which is useful in case the argument - was a function call that has been inlined. */ - while (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_let_void_type)) { - Scheme_Let_Header *head = (Scheme_Let_Header *)rand; - int i; - inside = rand; - rand = head->body; - for (i = head->num_clauses; i--; ) { - inside = rand; - rand = ((Scheme_Compiled_Let_Value *)rand)->body; - } - } - - if (SAME_TYPE(SCHEME_TYPE(rand), scheme_application2_type)) { - Scheme_App2_Rec *app2 = (Scheme_App2_Rec *)rand; - if (SAME_OBJ(scheme_list_proc, app2->rator)) { - if (IS_NAMED_PRIM(app->rator, "car")) { - /* (car (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1) - || single_valued_noncm_expression(app2->rand, 5)) { - alt = app2->rand; - } - } else if (IS_NAMED_PRIM(app->rator, "cdr")) { - /* (cdr (list X)) */ - if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1)) - alt = scheme_null; - } - } - } else if (SAME_TYPE(SCHEME_TYPE(rand), scheme_application3_type)) { - Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)rand; - if (IS_NAMED_PRIM(app->rator, "car")) { - if (SAME_OBJ(scheme_cons_proc, app3->rator) - || SAME_OBJ(scheme_list_proc, app3->rator) - || SAME_OBJ(scheme_list_star_proc, app3->rator)) { - /* (car ({cons|list|cdr} X Y)) */ - if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1) - || single_valued_noncm_expression(app3->rand1, 5)) - && scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1)) { - alt = app3->rand1; - } - } - } else if (IS_NAMED_PRIM(app->rator, "cdr")) { - /* (car (cons X Y)) */ - if (SAME_OBJ(scheme_cons_proc, app3->rator)) { - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1) - || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1)) { - alt = app3->rand2; - } - } - } else if (IS_NAMED_PRIM(app->rator, "cadr")) { - if (SAME_OBJ(scheme_list_proc, app3->rator)) { - /* (cadr (list X Y)) */ - if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1) - || single_valued_noncm_expression(app3->rand2, 5)) - && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1)) { - alt = app3->rand2; - } - } - } - } - - if (alt) { - if (inside) { - if (SAME_TYPE(SCHEME_TYPE(inside), scheme_compiled_let_void_type)) - ((Scheme_Let_Header *)inside)->body = alt; - else - ((Scheme_Compiled_Let_Value *)inside)->body = alt; - return app->rand; - } - return alt; - } - } - - register_flonum_argument_types(NULL, app, NULL, info); - - return check_unbox_rotation((Scheme_Object *)app, app->rator, 1, info); -} - -static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *info, int context) -{ - Scheme_App3_Rec *app; - Scheme_Object *le; - int rator_flags = 0, sub_context = 0; - - app = (Scheme_App3_Rec *)o; - - /* Check for (apply ... (list ...)) early: */ - le = direct_apply((Scheme_Object *)app, app->rator, app->rand2); - if (le) return scheme_optimize_expr(le, info, context); - - le = check_app_let_rator(o, app->rator, info, 2, context); - if (le) return le; - - le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 0); - if (le) - return le; - - le = scheme_optimize_expr(app->rator, info, sub_context); - app->rator = le; - - { - /* Maybe found "((lambda" after optimizing; try again */ - le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 1); - if (le) - return le; - } - - /* 1st arg */ - - if (scheme_wants_flonum_arguments(app->rator, 0, 0)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; - - le = scheme_optimize_expr(app->rand1, info, sub_context); - app->rand1 = le; - - /* 2nd arg */ - - if (scheme_wants_flonum_arguments(app->rator, 1, 0)) - sub_context |= OPT_CONTEXT_FLONUM_ARG; - else - sub_context &= ~OPT_CONTEXT_FLONUM_ARG; - - le = scheme_optimize_expr(app->rand2, info, sub_context); - app->rand2 = le; - - /* Check for (apply ... (list ...)) after some optimizations: */ - le = direct_apply((Scheme_Object *)app, app->rator, app->rand2); - if (le) return finish_optimize_app(le, info, context, rator_flags); - - return finish_optimize_application3(app, info, context, rator_flags); -} - -static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimize_Info *info, int context, int rator_flags) -{ - Scheme_Object *le; - int all_vals = 1; - - info->size += 1; - - if (SCHEME_TYPE(app->rand1) < _scheme_compiled_values_types_) - all_vals = 0; - if (SCHEME_TYPE(app->rand2) < _scheme_compiled_values_types_) - all_vals = 0; - - - if (all_vals) { - le = try_optimize_fold(app->rator, (Scheme_Object *)app, info); - if (le) - return le; - } - - if (!purely_functional_primitive(app->rator, 2)) - info->vclock += 1; - - /* Check for (call-with-values (lambda () M) N): */ - if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) { - if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) { - Scheme_Closure_Data *data = (Scheme_Closure_Data *)app->rand1; - - if (!data->num_params) { - /* Convert to apply-values form: */ - return scheme_optimize_apply_values(app->rand2, data->code, info, - ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT) - ? ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE) - ? -1 - : 1) - : 0), - context); - } - } - } - - if (SAME_OBJ(scheme_procedure_arity_includes_proc, app->rator)) { - if (SCHEME_INTP(app->rand2)) { - Scheme_Object *proc; - Scheme_Case_Lambda *cl; - int i, cnt; - - proc = lookup_constant_proc(info, app->rand1); - if (proc) { - if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) { - cnt = 1; - cl = NULL; - } else { - cl = (Scheme_Case_Lambda *)proc; - cnt = cl->count; - } - - for (i = 0; i < cnt; i++) { - if (cl) proc = cl->array[i]; - - if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) { - Scheme_Closure_Data *data = (Scheme_Closure_Data *)proc; - int n = SCHEME_INT_VAL(app->rand2), ok; - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) { - ok = ((data->num_params - 1) <= n); - } else { - ok = (data->num_params == n); - } - if (ok) { - info->preserves_marks = 1; - info->single_result = 1; - return scheme_true; - } - } else { - break; - } - } - - if (i == cnt) { - info->preserves_marks = 1; - info->single_result = 1; - return scheme_false; - } - } - } - } - - info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); - info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); - if (rator_flags & CLOS_RESULT_TENTATIVE) { - info->preserves_marks = -info->preserves_marks; - info->single_result = -info->single_result; - } - - /* Ad hoc optimization of (unsafe-fx+ 0), etc. */ - if (SCHEME_PRIMP(app->rator) - && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)) { - int z1, z2; - - z1 = SAME_OBJ(app->rand1, scheme_make_integer(0)); - z2 = SAME_OBJ(app->rand2, scheme_make_integer(0)); - if (IS_NAMED_PRIM(app->rator, "unsafe-fx+")) { - if (z1) - return app->rand2; - else if (z2) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx-")) { - if (z2) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx*")) { - if (z1 || z2) - return scheme_make_integer(0); - if (SAME_OBJ(app->rand1, scheme_make_integer(1))) - return app->rand2; - if (SAME_OBJ(app->rand2, scheme_make_integer(1))) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx/") - || IS_NAMED_PRIM(app->rator, "unsafe-fxquotient")) { - if (z1) - return scheme_make_integer(0); - if (SAME_OBJ(app->rand2, scheme_make_integer(1))) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-fxremainder") - || IS_NAMED_PRIM(app->rator, "unsafe-fxmodulo")) { - if (z1) - return scheme_make_integer(0); - if (SAME_OBJ(app->rand2, scheme_make_integer(1))) - return scheme_make_integer(0); - } - - z1 = (SCHEME_FLOATP(app->rand1) && (SCHEME_FLOAT_VAL(app->rand1) == 0.0)); - z2 = (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 0.0)); - - if (IS_NAMED_PRIM(app->rator, "unsafe-fl+")) { - if (z1) - return app->rand2; - else if (z2) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl-")) { - if (z2) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl*")) { - if (SCHEME_FLOATP(app->rand1) && (SCHEME_FLOAT_VAL(app->rand1) == 1.0)) - return app->rand2; - if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl/") - || IS_NAMED_PRIM(app->rator, "unsafe-flquotient")) { - if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) - return app->rand1; - } else if (IS_NAMED_PRIM(app->rator, "unsafe-flremainder") - || IS_NAMED_PRIM(app->rator, "unsafe-flmodulo")) { - if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) - return scheme_make_double(0.0); - } - } - - register_flonum_argument_types(NULL, NULL, app, info); - - return check_unbox_rotation((Scheme_Object *)app, app->rator, 2, info); -} - -Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, - Optimize_Info *info, - int e_single_result, - int context) -/* f and e are already optimized */ -{ - Scheme_Object *f_is_proc = NULL; - - info->preserves_marks = 0; - info->single_result = 0; - - { - Scheme_Object *rev; - if (SAME_TYPE(SCHEME_TYPE(f), scheme_local_type)) { - rev = scheme_optimize_reverse(info, SCHEME_LOCAL_POS(f), 1); - } else - rev = f; - - if (rev) { - int rator2_flags; - Scheme_Object *o_f; - o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags, context, 0); - if (o_f) { - f_is_proc = rev; - - if (SAME_TYPE(SCHEME_TYPE(o_f), scheme_compiled_unclosed_procedure_type)) { - Scheme_Closure_Data *data2 = (Scheme_Closure_Data *)o_f; - int flags = SCHEME_CLOSURE_DATA_FLAGS(data2); - info->preserves_marks = !!(flags & CLOS_PRESERVES_MARKS); - info->single_result = !!(flags & CLOS_SINGLE_RESULT); - if (flags & CLOS_RESULT_TENTATIVE) { - info->preserves_marks = -info->preserves_marks; - info->single_result = -info->single_result; - } - } - } - } - - if (!f_is_proc && SCHEME_PROCP(f)) { - f_is_proc = f; - } - } - - if (f_is_proc && (e_single_result > 0)) { - /* Just make it an application (N M): */ - Scheme_App2_Rec *app2; - Scheme_Object *cloned, *f_cloned; - - app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec); - app2->iso.so.type = scheme_application2_type; - - /* We'd like to try to inline here. The problem is that - e (the argument) has been optimized already, - which means it's in the wrong coordinate system. - If we can shift-clone it, then it will be back in the right - coordinates. */ - - cloned = scheme_optimize_clone(1, e, info, 0, 0); - if (cloned) { - if (SAME_TYPE(SCHEME_TYPE(f_is_proc), scheme_compiled_unclosed_procedure_type)) - f_cloned = scheme_optimize_clone(1, f_is_proc, info, 0, 0); - else { - /* Otherwise, no clone is needed; in the case of a lexical - variable, we already reversed it. */ - f_cloned = f_is_proc; - } - - if (f_cloned) { - app2->rator = f_cloned; - app2->rand = cloned; - info->inline_fuel >>= 1; /* because we've already optimized the rand */ - return optimize_application2((Scheme_Object *)app2, info, context); - } - } - - app2->rator = f; - app2->rand = e; - return (Scheme_Object *)app2; - } - - { - Scheme_Object *av; - av = scheme_alloc_object(); - av->type = scheme_apply_values_type; - SCHEME_PTR1_VAL(av) = f; - SCHEME_PTR2_VAL(av) = e; - return av; - } -} - -static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, int context) -{ - Scheme_Sequence *s = (Scheme_Sequence *)o; - Scheme_Object *le; - int i, count, prev_size; - int drop = 0, preserves_marks = 0, single_result = 0; - - count = s->count; - for (i = 0; i < count; i++) { - prev_size = info->size; - - le = scheme_optimize_expr(s->array[i], info, - ((i + 1 == count) - ? scheme_optimize_tail_context(context) - : 0)); - if (i == s->count - 1) { - single_result = info->single_result; - preserves_marks = info->preserves_marks; - } - - /* Inlining and constant propagation can expose - omittable expressions. */ - if ((i + 1 != count) - && scheme_omittable_expr(le, -1, -1, 0, NULL, -1)) { - drop++; - info->size = prev_size; - s->array[i] = NULL; - } else { - s->array[i] = le; - } - } - - info->preserves_marks = preserves_marks; - info->single_result = single_result; - - if (drop + 1 == s->count) { - return s->array[drop]; - } else if (drop) { - Scheme_Sequence *s2; - int j = 0; - - s2 = malloc_sequence(s->count - drop); - s2->so.type = s->so.type; - s2->count = s->count - drop; - - for (i = 0; i < s->count; i++) { - if (s->array[i]) { - s2->array[j++] = s->array[i]; - } - } - - s = s2; - } - - return (Scheme_Object *)s; -} - -int scheme_compiled_duplicate_ok(Scheme_Object *fb) -{ - return (SCHEME_VOIDP(fb) - || SAME_OBJ(fb, scheme_true) - || SCHEME_FALSEP(fb) - || SCHEME_SYMBOLP(fb) - || SCHEME_KEYWORDP(fb) - || SCHEME_EOFP(fb) - || SCHEME_INTP(fb) - || SCHEME_NULLP(fb) - || (SCHEME_CHARP(fb) && (SCHEME_CHAR_VAL(fb) < 256)) - || SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type) - /* Values that are hashed by the printer to avoid - duplication: */ - || SCHEME_CHAR_STRINGP(fb) - || SCHEME_BYTE_STRINGP(fb) - || SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type) - || SCHEME_NUMBERP(fb) - || SCHEME_PRIMP(fb)); -} - -static int equivalent_exprs(Scheme_Object *a, Scheme_Object *b) -{ - if (SAME_OBJ(a, b)) - return 1; - if (SAME_TYPE(SCHEME_TYPE(a), scheme_local_type) - && SAME_TYPE(SCHEME_TYPE(b), scheme_local_type) - && (SCHEME_LOCAL_POS(a) == SCHEME_LOCAL_POS(b))) - return 1; - - return 0; -} - -static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int context) -{ - Scheme_Branch_Rec *b; - Scheme_Object *t, *tb, *fb; - int preserves_marks = 1, single_result = 1; - - b = (Scheme_Branch_Rec *)o; - - t = b->test; - tb = b->tbranch; - fb = b->fbranch; - - if (context & OPT_CONTEXT_BOOLEAN) { - /* For test position, convert (if #t #f) to */ - if (SAME_OBJ(tb, scheme_true) && SAME_OBJ(fb, scheme_false)) - return scheme_optimize_expr(t, info, context); - - /* Convert (if expr) to (if #t expr) */ - if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type) - && SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type) - && (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb))) { - b->tbranch = tb = scheme_true; - } - } - - t = scheme_optimize_expr(t, info, OPT_CONTEXT_BOOLEAN); - - /* Try optimize: (if (not x) y z) => (if x z y) */ - while (1) { - if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) { - Scheme_App2_Rec *app; - - app = (Scheme_App2_Rec *)t; - if (SAME_PTR(scheme_not_prim, app->rator)) { - t = tb; - tb = fb; - fb = t; - t = app->rand; - } else - break; - } else - break; - } - - info->vclock += 1; /* model branch as clock increment */ - - if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) { - info->size -= 1; - if (SCHEME_FALSEP(t)) - return scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); - else - return scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); - } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_quote_syntax_type) - || SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_unclosed_procedure_type)) { - info->size -= 1; /* could be more precise for better for procedure size */ - return scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); - } - - tb = scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); - - if (!info->preserves_marks) - preserves_marks = 0; - else if (info->preserves_marks < 0) - preserves_marks = -1; - if (!info->single_result) - single_result = 0; - else if (info->single_result < 0) - single_result = -1; - - fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); - - if (!info->preserves_marks) - preserves_marks = 0; - else if (preserves_marks && (info->preserves_marks < 0)) - preserves_marks = -1; - if (!info->single_result) - single_result = 0; - else if (single_result && (info->single_result < 0)) - single_result = -1; - - info->vclock += 1; /* model join as clock increment */ - info->preserves_marks = preserves_marks; - info->single_result = single_result; - - /* Try optimize: (if x x #f) => x */ - if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type) - && SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type) - && (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb)) - && SCHEME_FALSEP(fb)) { - info->size -= 2; - return t; - } - - /* Try optimize: (if v v) => v */ - if (scheme_omittable_expr(t, 1, 20, 0, NULL, -1) - && equivalent_exprs(tb, fb)) { - info->size -= 2; /* could be more precise */ - return tb; - } - - /* Convert: (if (if M N #f) M2 K) => (if M (if N M2 K) K) - for simple constants K. This is useful to expose simple - tests to the JIT. */ - if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) - && scheme_compiled_duplicate_ok(fb)) { - Scheme_Branch_Rec *b2 = (Scheme_Branch_Rec *)t; - if (SCHEME_FALSEP(b2->fbranch)) { - Scheme_Branch_Rec *b3; - b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); - b3->so.type = scheme_branch_type; - b3->test = b2->tbranch; - b3->tbranch = tb; - b3->fbranch = fb; - t = b2->test; - tb = (Scheme_Object *)b3; - } - } - - b->test = t; - b->tbranch = tb; - b->fbranch = fb; - - if (OPT_BRANCH_ADDS_NO_SIZE) { - /* Seems to work better to not to increase the size - specifically for `if' */ - } else { - info->size += 1; - } - - return o; -} - -static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int context) -{ - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; - Scheme_Object *k, *v, *b; - - k = scheme_optimize_expr(wcm->key, info, 0); - - v = scheme_optimize_expr(wcm->val, info, 0); - - b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); - - if (scheme_omittable_expr(k, 1, 20, 0, info, -1) - && scheme_omittable_expr(v, 1, 20, 0, info, -1) - && scheme_omittable_expr(b, -1, 20, 0, info, -1)) - return b; - - /* info->single_result is already set */ - info->preserves_marks = 0; - - wcm->key = k; - wcm->val = v; - wcm->body = b; - - info->size += 1; - - return (Scheme_Object *)wcm; -} - -static Scheme_Object *optimize_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1; - Optimize_Info *info = (Optimize_Info *)p->ku.k.p2; - int context = p->ku.k.i1; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return scheme_optimize_expr(expr, info, context); -} - -Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context) -{ - Scheme_Type type = SCHEME_TYPE(expr); - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - - p->ku.k.p1 = (void *)expr; - p->ku.k.p2 = (void *)info; - p->ku.k.i1 = context; - - return scheme_handle_stack_overflow(optimize_k); - } -#endif - - info->preserves_marks = 1; - info->single_result = 1; - - switch (type) { - case scheme_local_type: - { - Scheme_Object *val; - int pos, delta; - - info->size += 1; - - pos = SCHEME_LOCAL_POS(expr); - - val = scheme_optimize_info_lookup(info, pos, NULL, NULL, - (context & OPT_CONTEXT_NO_SINGLE) ? 0 : 1, - context, NULL); - - if (val) { - if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) { - Scheme_Once_Used *o = (Scheme_Once_Used *)val; - if ((o->vclock == info->vclock) - && single_valued_noncm_expression(o->expr, 5)) { - val = scheme_optimize_clone(1, o->expr, info, o->delta, 0); - if (val) { - info->size -= 1; - o->used = 1; - return scheme_optimize_expr(val, info, context); - } - } - /* Can't move expression, so lookup again to mark as used - and to perform any copy propagation that might apply. */ - val = scheme_optimize_info_lookup(info, pos, NULL, NULL, 0, context, NULL); - if (val) - return val; - } else { - if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) { - info->size -= 1; - return scheme_optimize_expr(val, info, context); - } - return val; - } - } - - delta = scheme_optimize_info_get_shift(info, pos); - if (delta) - expr = scheme_make_local(scheme_local_type, pos + delta, 0); - - return expr; - } - case scheme_application_type: - return optimize_application(expr, info, context); - case scheme_application2_type: - return optimize_application2(expr, info, context); - case scheme_application3_type: - return optimize_application3(expr, info, context); - case scheme_sequence_type: - case scheme_splice_sequence_type: - return optimize_sequence(expr, info, context); - case scheme_branch_type: - return optimize_branch(expr, info, context); - case scheme_with_cont_mark_type: - return optimize_wcm(expr, info, context); - case scheme_compiled_unclosed_procedure_type: - return scheme_optimize_closure_compilation(expr, info, context); - case scheme_compiled_let_void_type: - return scheme_optimize_lets(expr, info, 0, context); - case scheme_compiled_toplevel_type: - info->size += 1; - if (info->top_level_consts) { - int pos; - Scheme_Object *c; - - while (1) { - pos = SCHEME_TOPLEVEL_POS(expr); - c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - c = scheme_no_potential_size(c); - if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type)) - expr = c; - else - break; - } - - if (c) { - if (scheme_compiled_duplicate_ok(c)) - return c; - - /* We can't inline, but mark the top level as a constant, - so we can direct-jump and avoid null checks in JITed code: */ - expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); - } else { - /* false is mapped to a table of non-constant ready values: */ - c = scheme_hash_get(info->top_level_consts, scheme_false); - if (c) { - c = scheme_hash_get((Scheme_Hash_Table *)c, scheme_make_integer(pos)); - - if (c) { - /* We can't inline, but mark the top level as ready, - so we can avoid null checks in JITed code: */ - expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY); - } - } - if (!c) - info->vclock += 1; - } - } else { - info->vclock += 1; - } - scheme_optimize_info_used_top(info); - return expr; - case scheme_compiled_quote_syntax_type: - info->size += 1; - scheme_optimize_info_used_top(info); - return expr; - case scheme_variable_type: - case scheme_module_variable_type: - scheme_signal_error("got top-level in wrong place"); - return 0; - case scheme_define_values_type: - return scheme_define_values_optimize(expr, info, context); - case scheme_varref_form_type: - return scheme_ref_optimize(expr, info, context); - case scheme_set_bang_type: - return scheme_set_optimize(expr, info, context); - case scheme_define_syntaxes_type: - return scheme_define_syntaxes_optimize(expr, info, context); - case scheme_define_for_syntax_type: - return scheme_define_for_syntaxes_optimize(expr, info, context); - case scheme_case_lambda_sequence_type: - return scheme_case_lambda_optimize(expr, info, context); - case scheme_begin0_sequence_type: - return scheme_begin0_optimize(expr, info, context); - case scheme_apply_values_type: - return scheme_apply_values_optimize(expr, info, context); - case scheme_require_form_type: - return scheme_top_level_require_optimize(expr, info, context); - case scheme_module_type: - return scheme_module_optimize(expr, info, context); - default: - info->size += 1; - return expr; - } -} - -Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *info, int delta, int closure_depth) -/* Past closure_depth, need to reverse optimize to unoptimzed with respect to info; - delta is the amount to skip in info to get to the frame that bound the code. - If dup_ok is 1, then the old copy will be dropped, so it's ok to "duplicate" - any constant. */ -{ - int t; - - t = SCHEME_TYPE(expr); - - switch(t) { - case scheme_local_type: - { - int pos = SCHEME_LOCAL_POS(expr); - if (pos >= closure_depth) { - expr = scheme_optimize_reverse(info, pos + delta - closure_depth, 0); - if (closure_depth) - expr = scheme_make_local(scheme_local_type, SCHEME_LOCAL_POS(expr) + closure_depth, 0); - } - return expr; - } - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr, *app2; - - app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec); - app2->iso.so.type = scheme_application2_type; - - expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth); - if (!expr) return NULL; - app2->rator = expr; - - expr = scheme_optimize_clone(dup_ok, app->rand, info, delta, closure_depth); - if (!expr) return NULL; - app2->rand = expr; - - return (Scheme_Object *)app2; - } - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)expr, *app2; - int i; - - app2 = scheme_malloc_application(app->num_args + 1); - - for (i = app->num_args + 1; i--; ) { - expr = scheme_optimize_clone(dup_ok, app->args[i], info, delta, closure_depth); - if (!expr) return NULL; - app2->args[i] = expr; - } - - return (Scheme_Object *)app2; - } - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr, *app2; - - app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec); - app2->iso.so.type = scheme_application3_type; - - expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth); - if (!expr) return NULL; - app2->rator = expr; - - expr = scheme_optimize_clone(dup_ok, app->rand1, info, delta, closure_depth); - if (!expr) return NULL; - app2->rand1 = expr; - - expr = scheme_optimize_clone(dup_ok, app->rand2, info, delta, closure_depth); - if (!expr) return NULL; - app2->rand2 = expr; - - return (Scheme_Object *)app2; - } - case scheme_compiled_let_void_type: - { - Scheme_Let_Header *head = (Scheme_Let_Header *)expr, *head2; - Scheme_Object *body; - Scheme_Compiled_Let_Value *lv, *lv2, *prev = NULL; - int i, *flags, sz; - int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); - - head2 = MALLOC_ONE_TAGGED(Scheme_Let_Header); - head2->iso.so.type = scheme_compiled_let_void_type; - head2->count = head->count; - head2->num_clauses = head->num_clauses; - SCHEME_LET_FLAGS(head2) = SCHEME_LET_FLAGS(head); - - /* Build let-value change: */ - body = head->body; - for (i = head->num_clauses; i--; ) { - lv = (Scheme_Compiled_Let_Value *)body; - - sz = sizeof(int) * lv->count; - flags = (int *)scheme_malloc_atomic(sz); - memcpy(flags, lv->flags, sz); - - lv2 = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - SCHEME_CLV_FLAGS(lv2) |= (SCHEME_CLV_FLAGS(lv) & 0x1); - lv2->iso.so.type = scheme_compiled_let_value_type; - lv2->count = lv->count; - lv2->position = lv->position; - lv2->flags = flags; - - expr = scheme_optimize_clone(dup_ok, lv->value, info, delta, - closure_depth + (post_bind ? 0 : head->count)); - if (!expr) return NULL; - lv2->value = expr; - - if (prev) - prev->body = (Scheme_Object *)lv2; - else - head2->body = (Scheme_Object *)lv2; - prev = lv2; - - body = lv->body; - } - if (prev) - prev->body = body; - else - head2->body = body; - - expr = scheme_optimize_clone(dup_ok, body, info, delta, closure_depth + head->count); - if (!expr) return NULL; - - if (prev) - prev->body = expr; - else - head2->body = expr; - - return (Scheme_Object *)head2; - } - case scheme_sequence_type: - case scheme_begin0_sequence_type: - case scheme_splice_sequence_type: - { - Scheme_Sequence *seq = (Scheme_Sequence *)expr, *seq2; - int i; - - seq2 = malloc_sequence(seq->count); - seq2->so.type = seq->so.type; - seq2->count = seq->count; - - for (i = seq->count; i--; ) { - expr = scheme_optimize_clone(dup_ok, seq->array[i], info, delta, closure_depth); - if (!expr) return NULL; - seq2->array[i] = expr; - } - - return (Scheme_Object *)seq2; - } - case scheme_branch_type: - { - Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr, *b2; - - b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); - b2->so.type = scheme_branch_type; - - expr = scheme_optimize_clone(dup_ok, b->test, info, delta, closure_depth); - if (!expr) return NULL; - b2->test = expr; - - expr = scheme_optimize_clone(dup_ok, b->tbranch, info, delta, closure_depth); - if (!expr) return NULL; - b2->tbranch = expr; - - expr = scheme_optimize_clone(dup_ok, b->fbranch, info, delta, closure_depth); - if (!expr) return NULL; - b2->fbranch = expr; - - return (Scheme_Object *)b2; - } - case scheme_with_cont_mark_type: - { - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr, *wcm2; - - wcm2 = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - wcm2->so.type = scheme_with_cont_mark_type; - - expr = scheme_optimize_clone(dup_ok, wcm->key, info, delta, closure_depth); - if (!expr) return NULL; - wcm2->key = expr; - - expr = scheme_optimize_clone(dup_ok, wcm->val, info, delta, closure_depth); - if (!expr) return NULL; - wcm2->val = expr; - - expr = scheme_optimize_clone(dup_ok, wcm->body, info, delta, closure_depth); - if (!expr) return NULL; - wcm2->body = expr; - - return (Scheme_Object *)wcm2; - } - case scheme_compiled_unclosed_procedure_type: - return scheme_clone_closure_compilation(dup_ok, expr, info, delta, closure_depth); - case scheme_compiled_toplevel_type: - case scheme_compiled_quote_syntax_type: - return expr; - case scheme_define_values_type: - case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: - case scheme_set_bang_type: - case scheme_boxenv_type: - return NULL; - case scheme_require_form_type: - return NULL; - case scheme_varref_form_type: - return NULL; - case scheme_apply_values_type: - return scheme_apply_values_clone(dup_ok, expr, info, delta, closure_depth); - case scheme_case_lambda_sequence_type: - return scheme_case_lambda_clone(dup_ok, expr, info, delta, closure_depth); - case scheme_module_type: - return NULL; - default: - if (t > _scheme_compiled_values_types_) { - if (dup_ok || scheme_compiled_duplicate_ok(expr)) - return expr; - } - } - - return NULL; -} - -Scheme_Object *scheme_optimize_shift(Scheme_Object *expr, int delta, int after_depth) -/* Shift lexical addresses deeper by delta if already deeper than after_depth; - can mutate. */ -{ - int t; - - /* FIXME: need stack check */ - - t = SCHEME_TYPE(expr); - - switch(t) { - case scheme_local_type: - case scheme_local_unbox_type: - { - int pos = SCHEME_LOCAL_POS(expr); - if (pos >= after_depth) { - expr = scheme_make_local(t, SCHEME_LOCAL_POS(expr) + delta, 0); - } - return expr; - } - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)expr; - int i; - - for (i = app->num_args + 1; i--; ) { - expr = scheme_optimize_shift(app->args[i], delta, after_depth); - app->args[i] = expr; - } - - return (Scheme_Object *)app; - } - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; - - expr = scheme_optimize_shift(app->rator, delta, after_depth); - app->rator = expr; - - expr = scheme_optimize_shift(app->rand, delta, after_depth); - app->rand = expr; - - return (Scheme_Object *)app; - } - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; - - expr = scheme_optimize_shift(app->rator, delta, after_depth); - app->rator = expr; - - expr = scheme_optimize_shift(app->rand1, delta, after_depth); - app->rand1 = expr; - - expr = scheme_optimize_shift(app->rand2, delta, after_depth); - app->rand2 = expr; - - return (Scheme_Object *)app; - } - case scheme_compiled_let_void_type: - { - Scheme_Let_Header *head = (Scheme_Let_Header *)expr; - Scheme_Object *body; - Scheme_Compiled_Let_Value *lv = NULL; - int i; - int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); - - /* Build let-value change: */ - body = head->body; - for (i = head->num_clauses; i--; ) { - lv = (Scheme_Compiled_Let_Value *)body; - - expr = scheme_optimize_shift(lv->value, delta, after_depth + (post_bind ? 0 : head->count)); - lv->value = expr; - - body = lv->body; - } - expr = scheme_optimize_shift(body, delta, after_depth + head->count); - - if (head->num_clauses) - lv->body = expr; - else - head->body = expr; - - return (Scheme_Object *)head; - } - case scheme_sequence_type: - case scheme_splice_sequence_type: - case scheme_begin0_sequence_type: - { - Scheme_Sequence *seq = (Scheme_Sequence *)expr; - int i; - - for (i = seq->count; i--; ) { - expr = scheme_optimize_shift(seq->array[i], delta, after_depth); - seq->array[i] = expr; - } - - return (Scheme_Object *)seq; - } - case scheme_branch_type: - { - Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr; - - expr = scheme_optimize_shift(b->test, delta, after_depth); - b->test = expr; - - expr = scheme_optimize_shift(b->tbranch, delta, after_depth); - b->tbranch = expr; - - expr = scheme_optimize_shift(b->fbranch, delta, after_depth); - b->fbranch = expr; - - return (Scheme_Object *)b; - } - case scheme_with_cont_mark_type: - { - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr; - - expr = scheme_optimize_shift(wcm->key, delta, after_depth); - wcm->key = expr; - - expr = scheme_optimize_shift(wcm->val, delta, after_depth); - wcm->val = expr; - - expr = scheme_optimize_shift(wcm->body, delta, after_depth); - wcm->body = expr; - - return (Scheme_Object *)wcm; - } - case scheme_compiled_unclosed_procedure_type: - return scheme_shift_closure_compilation(expr, delta, after_depth); - case scheme_compiled_toplevel_type: - case scheme_compiled_quote_syntax_type: - return expr; - case scheme_set_bang_type: - return scheme_set_shift(expr, delta, after_depth); - case scheme_varref_form_type: - return scheme_ref_shift(expr, delta, after_depth); - case scheme_apply_values_type: - return scheme_apply_values_shift(expr, delta, after_depth); - case scheme_case_lambda_sequence_type: - return scheme_case_lambda_shift(expr, delta, after_depth); - case scheme_boxenv_type: - case scheme_define_values_type: - case scheme_define_syntaxes_type: - case scheme_define_for_syntax_type: - case scheme_require_form_type: - case scheme_module_type: - scheme_signal_error("scheme_optimize_shift: no shift available for %d", SCHEME_TYPE(expr)); - return NULL; - default: - return expr; - } - - return NULL; -} - -/*========================================================================*/ -/* sfs */ -/*========================================================================*/ - -/* For debugging and measuring the worst-case cost of sfs clears: */ -#define MAX_SFS_CLEARING 0 - -#define SFS_LOG(x) /* nothing */ - -Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth) -{ - int init, i; - - SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o))); - - if (!info) { - info = scheme_new_sfs_info(max_let_depth); - } - - info->pass = 0; - info->ip = 1; - info->saved = scheme_null; - info->min_touch = -1; - info->max_touch = -1; - info->tail_pos = 1; - init = info->stackpos; - o = scheme_sfs_expr(o, info, -1); - - if (info->seqn) - scheme_signal_error("ended in the middle of an expression?"); - -# if MAX_SFS_CLEARING - info->max_nontail = info->ip; -# endif - - for (i = info->depth; i-- > init; ) { - info->max_calls[i] = info->max_nontail; - } - - { - Scheme_Object *v; - v = scheme_reverse(info->saved); - info->saved = v; - } - - info->pass = 1; - info->seqn = 0; - info->ip = 1; - info->tail_pos = 1; - info->stackpos = init; - o = scheme_sfs_expr(o, info, -1); - - return o; -} - -SFS_Info *scheme_new_sfs_info(int depth) -{ - SFS_Info *info; - int *max_used, *max_calls; - - info = MALLOC_ONE_RT(SFS_Info); - SET_REQUIRED_TAG(info->type = scheme_rt_sfs_info); - - info->depth = depth; - info->stackpos = depth; - info->tlpos = depth; - - max_used = (int *)scheme_malloc_atomic(sizeof(int) * depth); - max_calls = (int *)scheme_malloc_atomic(sizeof(int) * depth); - - memset(max_used, 0, sizeof(int) * depth); - memset(max_calls, 0, sizeof(int) * depth); - - info->max_used = max_used; - info->max_calls = max_calls; - - return info; -} - -static void scheme_sfs_save(SFS_Info *info, Scheme_Object *v) -{ - if (info->pass) - scheme_signal_error("internal error: wrong pass to save info"); - v = scheme_make_pair(v, info->saved); - info->saved = v; -} - -static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info) -{ - Scheme_Object *v; - - if (!info->pass) - scheme_signal_error("internal error: wrong pass to get saved info"); - if (!SCHEME_PAIRP(info->saved)) - scheme_signal_error("internal error: no saved info"); - - v = SCHEME_CAR(info->saved); - info->saved = SCHEME_CDR(info->saved); - return v; -} - -void scheme_sfs_start_sequence(SFS_Info *info, int cnt, int last_is_tail) -{ - info->seqn += (cnt - (last_is_tail ? 1 : 0)); -} - -void scheme_sfs_push(SFS_Info *info, int cnt, int track) -{ - info->stackpos -= cnt; - - if (info->stackpos < 0) - scheme_signal_error("internal error: pushed too deep"); - - if (track) { - while (cnt--) { - scheme_sfs_used(info, cnt); - } - } -} - -void scheme_sfs_used(SFS_Info *info, int pos) -{ - if (info->pass) - return; - - pos += info->stackpos; - - if ((pos < 0) || (pos >= info->depth)) { - scheme_signal_error("internal error: stack use out of bounds"); - } - if (pos == info->tlpos) - scheme_signal_error("internal error: misuse of toplevel pointer"); - - SFS_LOG(printf("touch %d %d\n", pos, info->ip)); - - if ((info->min_touch == -1) - || (pos < info->min_touch)) - info->min_touch = pos; - if (pos > info->max_touch) - info->max_touch = pos; - - info->max_used[pos] = info->ip; -} - -Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre) -{ - int len, i; - Scheme_Object *loc; - Scheme_Sequence *s; - - if (SCHEME_NULLP(clears)) - return expr; - - len = scheme_list_length(clears); - - s = malloc_sequence(len + 1); - s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type); - s->count = len + 1; - s->array[pre ? len : 0] = expr; - - for (i = 0; i < len; i++) { - loc = scheme_make_local(scheme_local_type, - SCHEME_INT_VAL(SCHEME_CAR(clears)), - SCHEME_LOCAL_CLEAR_ON_READ); - s->array[i + (pre ? 0 : 1)] = loc; - clears = SCHEME_CDR(clears); - } - - return (Scheme_Object *)s; -} - -static void sfs_note_app(SFS_Info *info, Scheme_Object *rator) -{ - if (!info->pass) { - if (!info->tail_pos) { - if (SAME_OBJ(scheme_values_func, rator)) - /* no need to clear for app of `values' */ - return; - if (SCHEME_PRIMP(rator)) { - int opt; - opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; - if (opt >= SCHEME_PRIM_OPT_IMMEDIATE) - /* Don't need to clear stack before an immediate/folding call */ - return; - } - info->max_nontail = info->ip; - } else { - if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) { - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) { - if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) { - /* No point in clearing out any of the closure before the - tail call. */ - int i; - for (i = info->selflen; i--; ) { - if ((info->selfstart + i) != info->tlpos) - scheme_sfs_used(info, (info->selfstart - info->stackpos) + i); - } - } - } - } - } - } -} - -static Scheme_Object *sfs_application(Scheme_Object *o, SFS_Info *info) -{ - Scheme_Object *orig, *naya = NULL; - Scheme_App_Rec *app; - int i, n; - - app = (Scheme_App_Rec *)o; - n = app->num_args + 1; - - scheme_sfs_start_sequence(info, n, 0); - scheme_sfs_push(info, n-1, 0); - - for (i = 0; i < n; i++) { - orig = app->args[i]; - naya = scheme_sfs_expr(orig, info, -1); - app->args[i] = naya; - } - - sfs_note_app(info, app->args[0]); - - scheme_finish_application(app); - - return o; -} - -static Scheme_Object *sfs_application2(Scheme_Object *o, SFS_Info *info) -{ - Scheme_App2_Rec *app; - Scheme_Object *nrator, *nrand; - - app = (Scheme_App2_Rec *)o; - - scheme_sfs_start_sequence(info, 2, 0); - scheme_sfs_push(info, 1, 0); - - nrator = scheme_sfs_expr(app->rator, info, -1); - nrand = scheme_sfs_expr(app->rand, info, -1); - app->rator = nrator; - app->rand = nrand; - - sfs_note_app(info, app->rator); - - set_app2_eval_type(app); - - return o; -} - -static Scheme_Object *sfs_application3(Scheme_Object *o, SFS_Info *info) -{ - Scheme_App3_Rec *app; - Scheme_Object *nrator, *nrand1, *nrand2; - - app = (Scheme_App3_Rec *)o; - - scheme_sfs_start_sequence(info, 3, 0); - scheme_sfs_push(info, 2, 0); - - nrator = scheme_sfs_expr(app->rator, info, -1); - nrand1 = scheme_sfs_expr(app->rand1, info, -1); - nrand2 = scheme_sfs_expr(app->rand2, info, -1); - - app->rator = nrator; - app->rand1 = nrand1; - app->rand2 = nrand2; - - sfs_note_app(info, app->rator); - - set_app3_eval_type(app); - - return o; -} - -static Scheme_Object *sfs_sequence(Scheme_Object *o, SFS_Info *info) -{ - Scheme_Object *orig, *naya; - Scheme_Sequence *seq; - int i, n; - - seq = (Scheme_Sequence *)o; - n = seq->count; - - scheme_sfs_start_sequence(info, n, 1); - - for (i = 0; i < n; i++) { - orig = seq->array[i]; - naya = scheme_sfs_expr(orig, info, -1); - seq->array[i] = naya; - } - - return o; -} - -#define SFS_BRANCH_W 4 - -static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, - Scheme_Object *vec, int delta, - Scheme_Object *tbranch) -{ - int t_min_t, t_max_t, t_cnt, n, stackpos, i, save_nt, b_end, nt; - Scheme_Object *t_vec, *o; - Scheme_Object *clears = scheme_null; - - info->min_touch = -1; - info->max_touch = -1; - save_nt = info->max_nontail; - - SFS_LOG(printf("%d %d %s %d\n", info->pass, ip, (delta ? "else" : "then"), ip)); - - if (info->pass) { - /* Re-install max_used entries that refer to the branch */ - o = SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W]; - t_min_t = SCHEME_INT_VAL(o); - o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2]; - nt = SCHEME_INT_VAL(o); - if (nt > info->max_nontail) - info->max_nontail = nt; - if (t_min_t > -1) { - t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1]; - t_cnt = SCHEME_VEC_SIZE(t_vec); - for (i = 0; i < t_cnt; i++) { - o = SCHEME_VEC_ELS(t_vec)[i]; - if (SCHEME_INTP(o)) { - n = SCHEME_INT_VAL(o); - SFS_LOG(printf(" @%d %d\n", i + t_min_t, n)); - if (info->max_used[i + t_min_t] < n) { - SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail)); - info->max_used[i + t_min_t] = n; - info->max_calls[i + t_min_t] = info->max_nontail; - } - } - } - } - /* If the other branch has last use for something not used in this - branch, and if there's a non-tail call in this branch - of later, then we'll have to start with explicit clears. - Note that it doesn't matter whether the other branch actually - clears them (i.e., the relevant non-tail call might be only - in this branch). */ - o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3]; - b_end = SCHEME_INT_VAL(o); - SFS_LOG(printf(" %d %d %d %d\n", nt, ip, b_end, save_nt)); - if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */ - || ((ip + 1) < save_nt)) { /* => non-tail call after branches */ - SFS_LOG(printf(" other\n")); - o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W]; - t_min_t = SCHEME_INT_VAL(o); - if (t_min_t > -1) { - int at_ip, pos; - t_vec = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 1]; - t_cnt = SCHEME_VEC_SIZE(t_vec); - o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 2]; - nt = SCHEME_INT_VAL(o); - o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 3]; - b_end = SCHEME_INT_VAL(o); - for (i = 0; i < t_cnt; i++) { - o = SCHEME_VEC_ELS(t_vec)[i]; - if (SCHEME_INTP(o)) { - n = SCHEME_INT_VAL(o); - pos = i + t_min_t; - at_ip = info->max_used[pos]; - SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip)); - /* is last use in other branch? */ - if (((!delta && (at_ip == ip)) - || (delta && (at_ip == n)))) { - /* Yes, so add clear */ - SFS_LOG(printf(" !%d %d %d\n", pos, n, at_ip)); - pos -= info->stackpos; - clears = scheme_make_pair(scheme_make_integer(pos), - clears); - } - } - } - } - } - } - - stackpos = info->stackpos; - - tbranch = scheme_sfs_expr(tbranch, info, -1); - - if (info->pass) - info->max_nontail = save_nt; -# if MAX_SFS_CLEARING - else - info->max_nontail = info->ip; -# endif - - tbranch = scheme_sfs_add_clears(tbranch, clears, 1); - - if (!info->pass) { - t_min_t = info->min_touch; - t_max_t = info->max_touch; - if (t_min_t < stackpos) - t_min_t = stackpos; - if (t_max_t < stackpos) - t_max_t = -1; - SFS_LOG(printf("%d %s %d [%d,%d] /%d\n", info->pass, (delta ? "else" : "then"), ip, - t_min_t, t_max_t, stackpos)); - if (t_max_t < 0) { - t_min_t = -1; - t_vec = scheme_false; - } else { - t_cnt = t_max_t - t_min_t + 1; - t_vec = scheme_make_vector(t_cnt, NULL); - for (i = 0; i < t_cnt; i++) { - n = info->max_used[i + t_min_t]; - SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip, - i + t_min_t, n, info->max_calls[i+ t_min_t])); - if (n > ip) { - SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n); - info->max_used[i + t_min_t] = ip; - } else { - SCHEME_VEC_ELS(t_vec)[i] = scheme_false; - } - } - } - SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W] = scheme_make_integer(t_min_t); - SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1] = t_vec; - SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2] = scheme_make_integer(info->max_nontail); - SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3] = scheme_make_integer(info->ip); - } - - memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); - memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); - - info->stackpos = stackpos; - - return tbranch; -} - -static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info) -{ - Scheme_Branch_Rec *b; - Scheme_Object *t, *tb, *fb, *vec; - int ip, min_t, max_t; - - b = (Scheme_Branch_Rec *)o; - - scheme_sfs_start_sequence(info, 1, 0); - - t = scheme_sfs_expr(b->test, info, -1); - - ip = info->ip; - info->ip++; - /* Use ip to represent all uses in the two branches. - Use ip+1 to represent all non-tail calls in the two branches. */ - - min_t = info->min_touch; - max_t = info->max_touch; - - SFS_LOG(printf(" after test: %d %d\n", min_t, max_t)); - - if (!info->pass) { - vec = scheme_make_vector(SFS_BRANCH_W * 2, NULL); - scheme_sfs_save(info, vec); - } else { - vec = scheme_sfs_next_saved(info); - } - - tb = sfs_one_branch(info, ip, vec, 0, b->tbranch); - - if (!info->pass) { - if ((min_t == -1) - || ((info->min_touch > -1) && (info->min_touch < min_t))) - min_t = info->min_touch; - if (info->max_touch > max_t) - max_t = info->max_touch; - if (info->max_nontail > ip + 1) - info->max_nontail = ip + 1; - } - - fb = sfs_one_branch(info, ip, vec, 1, b->fbranch); - - if (!info->pass) { - if ((min_t == -1) - || ((info->min_touch > -1) && (info->min_touch < min_t))) - min_t = info->min_touch; - if (info->max_touch > max_t) - max_t = info->max_touch; - if (info->max_nontail > ip + 1) - info->max_nontail = ip + 1; - } - - SFS_LOG(printf(" done if: %d %d\n", min_t, max_t)); - - info->min_touch = min_t; - info->max_touch = max_t; - - b->test = t; - b->tbranch = tb; - b->fbranch = fb; - - return o; -} - -static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info) -{ - Scheme_Let_Value *lv = (Scheme_Let_Value *)o; - Scheme_Object *body, *rhs, *clears = scheme_null; - int i, pos; - - scheme_sfs_start_sequence(info, 2, 1); - - rhs = scheme_sfs_expr(lv->value, info, -1); - - if (!info->pass - || (info->ip < info->max_nontail)) { - for (i = 0; i < lv->count; i++) { - pos = lv->position + i; - if (!info->pass) - scheme_sfs_used(info, pos); - else { - int spos; - spos = pos + info->stackpos; - if ((info->max_used[spos] == info->ip) - && (info->max_calls[spos] > info->ip)) { - /* No one is using the id after we set it. - We still need to set it, in case it's boxed and shared, - but then remove the binding or box. */ - clears = scheme_make_pair(scheme_make_integer(pos), - clears); - } - } - } - } - - body = scheme_sfs_expr(lv->body, info, -1); - - body = scheme_sfs_add_clears(body, clears, 1); - - lv->value = rhs; - lv->body = body; - - return o; -} - -static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) -{ - Scheme_Let_One *lo = (Scheme_Let_One *)o; - Scheme_Object *body, *rhs, *vec; - int pos, save_mnt, ip, et; - int unused = 0; - - scheme_sfs_start_sequence(info, 2, 1); - - scheme_sfs_push(info, 1, 1); - ip = info->ip; - pos = info->stackpos; - save_mnt = info->max_nontail; - - if (!info->pass) { - vec = scheme_make_vector(3, NULL); - scheme_sfs_save(info, vec); - } else { - vec = scheme_sfs_next_saved(info); - if (SCHEME_VEC_SIZE(vec) != 3) - scheme_signal_error("internal error: bad vector length"); - info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]); - info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]); - info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]); - } - - rhs = scheme_sfs_expr(lo->value, info, -1); - body = scheme_sfs_expr(lo->body, info, -1); - -# if MAX_SFS_CLEARING - if (!info->pass) - info->max_nontail = info->ip; -# endif - - if (!info->pass) { - int n; - info->max_calls[pos] = info->max_nontail; - n = info->max_used[pos]; - SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n); - n = info->max_calls[pos]; - SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n); - SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail); - } else { - info->max_nontail = save_mnt; - - if (info->max_used[pos] <= ip) { - /* No one is using it, so don't actually push the value at run time - (but keep the check that the result is single-valued). - The optimizer normally would have converted away the binding, but - it might not because (1) it was introduced late by inlining, - or (2) the rhs expression doesn't always produce a single - value. */ - if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) { - rhs = scheme_false; - } else if ((ip < info->max_calls[pos]) - && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { - /* Unusual case: we can't just drop the global-variable access, - because it might be undefined, but we don't need the value, - and we want to avoid an SFS clear in the interpreter loop. - So, bind #f and then access in the global in a `begin'. */ - Scheme_Sequence *s; - s = malloc_sequence(2); - s->so.type = scheme_sequence_type; - s->count = 2; - s->array[0] = rhs; - s->array[1] = body; - body = (Scheme_Object *)s; - rhs = scheme_false; - } - unused = 1; - } - } - - lo->value = rhs; - lo->body = body; - - et = scheme_get_eval_type(lo->value); - SCHEME_LET_EVAL_TYPE(lo) = (et - | (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM)) - | (unused ? LET_ONE_UNUSED : 0)); - - return o; -} - -static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info) -{ - Scheme_Let_Void *lv = (Scheme_Let_Void *)o; - Scheme_Object *body; - int i, pos, save_mnt; - Scheme_Object *vec; - - scheme_sfs_push(info, lv->count, 1); - pos = info->stackpos; - save_mnt = info->max_nontail; - - if (!info->pass) { - vec = scheme_make_vector(lv->count + 1, NULL); - scheme_sfs_save(info, vec); - } else { - vec = scheme_sfs_next_saved(info); - if (!SCHEME_VECTORP(vec)) - scheme_signal_error("internal error: not a vector"); - for (i = 0; i < lv->count; i++) { - info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]); - info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]); - } - info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]); - } - - body = scheme_sfs_expr(lv->body, info, -1); - -# if MAX_SFS_CLEARING - if (!info->pass) - info->max_nontail = info->ip; -# endif - - if (!info->pass) { - int n; - SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail); - for (i = 0; i < lv->count; i++) { - n = info->max_used[pos + i]; - SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n); - } - } else { - info->max_nontail = save_mnt; - } - - lv->body = body; - - return o; -} - -static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info) -{ - Scheme_Letrec *lr = (Scheme_Letrec *)o; - Scheme_Object **procs, *v, *clears = scheme_null; - int i, count; - - count = lr->count; - - scheme_sfs_start_sequence(info, count + 1, 1); - - procs = lr->procs; - - for (i = 0; i < count; i++) { - v = scheme_sfs_expr(procs[i], info, i); - - if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) { - /* Some clearing actions were added to the closure. - Lift them out. */ - int j; - Scheme_Sequence *cseq = (Scheme_Sequence *)v; - for (j = 1; j < cseq->count; j++) { - int pos; - pos = SCHEME_LOCAL_POS(cseq->array[j]); - clears = scheme_make_pair(scheme_make_integer(pos), clears); - } - v = cseq->array[0]; - } - procs[i] = v; - } - - v = scheme_sfs_expr(lr->body, info, -1); - - v = scheme_sfs_add_clears(v, clears, 1); - - lr->body = v; - - return o; -} - -static Scheme_Object *sfs_wcm(Scheme_Object *o, SFS_Info *info) -{ - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; - Scheme_Object *k, *v, *b; - - scheme_sfs_start_sequence(info, 3, 1); - - k = scheme_sfs_expr(wcm->key, info, -1); - v = scheme_sfs_expr(wcm->val, info, -1); - b = scheme_sfs_expr(wcm->body, info, -1); - - wcm->key = k; - wcm->val = v; - wcm->body = b; - - return o; -} - -Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos) -{ - Scheme_Type type = SCHEME_TYPE(expr); - int seqn, stackpos, tp; - - seqn = info->seqn; - stackpos = info->stackpos; - tp = info->tail_pos; - if (seqn) { - info->seqn = 0; - info->tail_pos = 0; - } - info->ip++; - - switch (type) { - case scheme_local_type: - case scheme_local_unbox_type: - if (!info->pass) - scheme_sfs_used(info, SCHEME_LOCAL_POS(expr)); - else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) { - int pos, at_ip; - pos = SCHEME_LOCAL_POS(expr); - at_ip = info->max_used[info->stackpos + pos]; - if (at_ip < info->max_calls[info->stackpos + pos]) { - if (at_ip == info->ip) { - /* Clear on read: */ - expr = scheme_make_local(type, pos, SCHEME_LOCAL_CLEAR_ON_READ); - } else { - /* Someone else clears it: */ - expr = scheme_make_local(type, pos, SCHEME_LOCAL_OTHER_CLEARS); - } - } else { -# if MAX_SFS_CLEARING - scheme_signal_error("should have been cleared somewhere"); -# endif - } - } - break; - case scheme_application_type: - expr = sfs_application(expr, info); - break; - case scheme_application2_type: - expr = sfs_application2(expr, info); - break; - case scheme_application3_type: - expr = sfs_application3(expr, info); - break; - case scheme_sequence_type: - case scheme_splice_sequence_type: - expr = sfs_sequence(expr, info); - break; - case scheme_branch_type: - expr = sfs_branch(expr, info); - break; - case scheme_with_cont_mark_type: - expr = sfs_wcm(expr, info); - break; - case scheme_unclosed_procedure_type: - expr = scheme_sfs_closure(expr, info, closure_self_pos); - break; - case scheme_let_value_type: - expr = sfs_let_value(expr, info); - break; - case scheme_let_void_type: - expr = sfs_let_void(expr, info); - break; - case scheme_letrec_type: - expr = sfs_letrec(expr, info); - break; - case scheme_let_one_type: - expr = sfs_let_one(expr, info); - break; - case scheme_closure_type: - { - Scheme_Closure *c = (Scheme_Closure *)expr; - if (ZERO_SIZED_CLOSUREP(c)) { - Scheme_Object *code; - code = scheme_sfs_closure((Scheme_Object *)c->code, info, closure_self_pos); - if (SAME_TYPE(SCHEME_TYPE(code), scheme_begin0_sequence_type)) { - Scheme_Sequence *seq = (Scheme_Sequence *)code; - c->code = (Scheme_Closure_Data *)seq->array[0]; - seq->array[0] = expr; - expr = code; - } else { - c->code = (Scheme_Closure_Data *)code; - } - } - } - break; - case scheme_toplevel_type: - { - int c = SCHEME_TOPLEVEL_DEPTH(expr); - if (info->stackpos + c != info->tlpos) - scheme_signal_error("toplevel access not at expected place"); - } - break; - case scheme_case_closure_type: - { - /* FIXME: maybe need to handle eagerly created closure */ - } - break; - case scheme_define_values_type: - expr = scheme_define_values_sfs(expr, info); - break; - case scheme_define_syntaxes_type: - expr = scheme_define_for_syntaxes_sfs(expr, info); - break; - case scheme_define_for_syntax_type: - expr = scheme_define_syntaxes_sfs(expr, info); - break; - case scheme_set_bang_type: - expr = scheme_set_sfs(expr, info); - break; - case scheme_boxenv_type: - expr = scheme_bangboxenv_sfs(expr, info); - break; - case scheme_begin0_sequence_type: - expr = scheme_begin0_sfs(expr, info); - break; - case scheme_require_form_type: - expr = scheme_top_level_require_sfs(expr, info); - break; - case scheme_varref_form_type: - expr = scheme_ref_sfs(expr, info); - break; - case scheme_apply_values_type: - expr = scheme_apply_values_sfs(expr, info); - break; - case scheme_case_lambda_sequence_type: - expr = scheme_case_lambda_sfs(expr, info); - break; - case scheme_module_type: - expr = scheme_module_sfs(expr, info); - break; - default: - break; - } - - info->ip++; - - if (seqn) { - info->seqn = seqn - 1; - memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); - memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); - info->stackpos = stackpos; - info->tail_pos = tp; - } - - return expr; -} - -/*========================================================================*/ -/* JIT */ -/*========================================================================*/ - -#ifdef MZ_USE_JIT - -static Scheme_Object *jit_application(Scheme_Object *o) -{ - Scheme_Object *orig, *naya = NULL; - Scheme_App_Rec *app, *app2; - int i, n, size; - - app = (Scheme_App_Rec *)o; - n = app->num_args + 1; - - for (i = 0; i < n; i++) { - orig = app->args[i]; - naya = scheme_jit_expr(orig); - if (!SAME_OBJ(orig, naya)) - break; - } - - if (i >= n) - return o; - - size = (sizeof(Scheme_App_Rec) - + ((n - 1) * sizeof(Scheme_Object *)) - + n * sizeof(char)); - app2 = (Scheme_App_Rec *)scheme_malloc_tagged(size); - memcpy(app2, app, size); - app2->args[i] = naya; - - for (i++; i < n; i++) { - orig = app2->args[i]; - naya = scheme_jit_expr(orig); - app2->args[i] = naya; - } - - return (Scheme_Object *)app2; -} - -static Scheme_Object *jit_application2(Scheme_Object *o) -{ - Scheme_App2_Rec *app; - Scheme_Object *nrator, *nrand; - - app = (Scheme_App2_Rec *)o; - - nrator = scheme_jit_expr(app->rator); - nrand = scheme_jit_expr(app->rand); - - if (SAME_OBJ(nrator, app->rator) - && SAME_OBJ(nrand, app->rand)) - return o; - - app = MALLOC_ONE_TAGGED(Scheme_App2_Rec); - memcpy(app, o, sizeof(Scheme_App2_Rec)); - app->rator = nrator; - app->rand = nrand; - - return (Scheme_Object *)app; -} - -static Scheme_Object *jit_application3(Scheme_Object *o) -{ - Scheme_App3_Rec *app; - Scheme_Object *nrator, *nrand1, *nrand2; - - app = (Scheme_App3_Rec *)o; - - nrator = scheme_jit_expr(app->rator); - nrand1 = scheme_jit_expr(app->rand1); - nrand2 = scheme_jit_expr(app->rand2); - - if (SAME_OBJ(nrator, app->rator) - && SAME_OBJ(nrand1, app->rand1) - && SAME_OBJ(nrand2, app->rand2)) - return o; - - app = MALLOC_ONE_TAGGED(Scheme_App3_Rec); - memcpy(app, o, sizeof(Scheme_App3_Rec)); - app->rator = nrator; - app->rand1 = nrand1; - app->rand2 = nrand2; - - return (Scheme_Object *)app; -} - -static Scheme_Object *jit_sequence(Scheme_Object *o) -{ - Scheme_Object *orig, *naya = NULL; - Scheme_Sequence *seq, *seq2; - int i, n, size; - - seq = (Scheme_Sequence *)o; - n = seq->count; - - for (i = 0; i < n; i++) { - orig = seq->array[i]; - naya = scheme_jit_expr(orig); - if (!SAME_OBJ(orig, naya)) - break; - } - - if (i >= n) - return o; - - size = (sizeof(Scheme_Sequence) - + ((n - 1) * sizeof(Scheme_Object *))); - seq2 = (Scheme_Sequence *)scheme_malloc_tagged(size); - memcpy(seq2, seq, size); - seq2->array[i] = naya; - - for (i++; i < n; i++) { - orig = seq2->array[i]; - naya = scheme_jit_expr(orig); - seq2->array[i] = naya; - } - - return (Scheme_Object *)seq2; -} - -static Scheme_Object *jit_branch(Scheme_Object *o) -{ - Scheme_Branch_Rec *b; - Scheme_Object *t, *tb, *fb; - - b = (Scheme_Branch_Rec *)o; - - t = scheme_jit_expr(b->test); - tb = scheme_jit_expr(b->tbranch); - fb = scheme_jit_expr(b->fbranch); - - if (SAME_OBJ(t, b->test) - && SAME_OBJ(tb, b->tbranch) - && SAME_OBJ(fb, b->fbranch)) - return o; - - b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); - memcpy(b, o, sizeof(Scheme_Branch_Rec)); - b->test = t; - b->tbranch = tb; - b->fbranch = fb; - - return (Scheme_Object *)b; -} - -static Scheme_Object *jit_let_value(Scheme_Object *o) -{ - Scheme_Let_Value *lv = (Scheme_Let_Value *)o; - Scheme_Object *body, *rhs; - - rhs = scheme_jit_expr(lv->value); - body = scheme_jit_expr(lv->body); - - if (SAME_OBJ(rhs, lv->value) - && SAME_OBJ(body, lv->body)) - return o; - - lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); - memcpy(lv, o, sizeof(Scheme_Let_Value)); - lv->value = rhs; - lv->body = body; - - return (Scheme_Object *)lv; -} - -static Scheme_Object *jit_let_one(Scheme_Object *o) -{ - Scheme_Let_One *lo = (Scheme_Let_One *)o; - Scheme_Object *body, *rhs; - - rhs = scheme_jit_expr(lo->value); - body = scheme_jit_expr(lo->body); - - if (SAME_OBJ(rhs, lo->value) - && SAME_OBJ(body, lo->body)) - return o; - - lo = MALLOC_ONE_TAGGED(Scheme_Let_One); - memcpy(lo, o, sizeof(Scheme_Let_One)); - lo->value = rhs; - lo->body = body; - - return (Scheme_Object *)lo; -} - -static Scheme_Object *jit_let_void(Scheme_Object *o) -{ - Scheme_Let_Void *lv = (Scheme_Let_Void *)o; - Scheme_Object *body; - - body = scheme_jit_expr(lv->body); - - if (SAME_OBJ(body, lv->body)) - return o; - - lv = MALLOC_ONE_TAGGED(Scheme_Let_Void); - memcpy(lv, o, sizeof(Scheme_Let_Void)); - lv->body = body; - - return (Scheme_Object *)lv; -} - -static Scheme_Object *jit_letrec(Scheme_Object *o) -{ - Scheme_Letrec *lr = (Scheme_Letrec *)o, *lr2; - Scheme_Object **procs, **procs2, *v; - int i, count; - - count = lr->count; - - lr2 = MALLOC_ONE_TAGGED(Scheme_Letrec); - memcpy(lr2, lr, sizeof(Scheme_Letrec)); - - procs = lr->procs; - procs2 = MALLOC_N(Scheme_Object *, count); - lr2->procs = procs2; - - for (i = 0; i < count; i++) { - v = scheme_jit_closure(procs[i], (Scheme_Object *)lr2); - procs2[i] = v; - } - - v = scheme_jit_expr(lr->body); - lr2->body = v; - - return (Scheme_Object *)lr2; -} - -static Scheme_Object *jit_wcm(Scheme_Object *o) -{ - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; - Scheme_Object *k, *v, *b; - - k = scheme_jit_expr(wcm->key); - v = scheme_jit_expr(wcm->val); - b = scheme_jit_expr(wcm->body); - if (SAME_OBJ(wcm->key, k) - && SAME_OBJ(wcm->val, v) - && SAME_OBJ(wcm->body, b)) - return o; - - wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - memcpy(wcm, o, sizeof(Scheme_With_Continuation_Mark)); - - wcm->key = k; - wcm->val = v; - wcm->body = b; - - return (Scheme_Object *)wcm; -} - -Scheme_Object *scheme_jit_expr(Scheme_Object *expr) -{ - Scheme_Type type = SCHEME_TYPE(expr); - - switch (type) { - case scheme_application_type: - return jit_application(expr); - case scheme_application2_type: - return jit_application2(expr); - case scheme_application3_type: - return jit_application3(expr); - case scheme_sequence_type: - case scheme_splice_sequence_type: - return jit_sequence(expr); - case scheme_branch_type: - return jit_branch(expr); - case scheme_with_cont_mark_type: - return jit_wcm(expr); - case scheme_unclosed_procedure_type: - return scheme_jit_closure(expr, NULL); - case scheme_let_value_type: - return jit_let_value(expr); - case scheme_let_void_type: - return jit_let_void(expr); - case scheme_letrec_type: - return jit_letrec(expr); - case scheme_let_one_type: - return jit_let_one(expr); - case scheme_closure_type: - { - Scheme_Closure *c = (Scheme_Closure *)expr; - if (ZERO_SIZED_CLOSUREP(c)) { - /* JIT the closure body, producing a native closure: */ - return scheme_jit_closure((Scheme_Object *)c->code, NULL); - } else - return expr; - } - case scheme_case_closure_type: - { - return scheme_unclose_case_lambda(expr, 1); - } - case scheme_define_values_type: - return scheme_define_values_jit(expr); - case scheme_define_syntaxes_type: - return scheme_define_syntaxes_jit(expr); - case scheme_define_for_syntax_type: - return scheme_define_for_syntaxes_jit(expr); - case scheme_set_bang_type: - return scheme_set_jit(expr); - case scheme_boxenv_type: - return scheme_bangboxenv_jit(expr); - case scheme_begin0_sequence_type: - return scheme_begin0_jit(expr); - case scheme_require_form_type: - return scheme_top_level_require_jit(expr); - case scheme_varref_form_type: - return scheme_ref_jit(expr); - case scheme_apply_values_type: - return scheme_apply_values_jit(expr); - case scheme_case_lambda_sequence_type: - return scheme_case_lambda_jit(expr); - case scheme_module_type: - return scheme_module_jit(expr); - default: - return expr; - } -} - -#else - -Scheme_Object *scheme_jit_expr(Scheme_Object *expr) -{ - return expr; -} - -#endif - -/*========================================================================*/ -/* compilation info management */ -/*========================================================================*/ - -void scheme_default_compile_rec(Scheme_Compile_Info *rec, int drec) -{ -} - -void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n) -{ - int i; - - for (i = 0; i < n; i++) { -#ifdef MZTAG_REQUIRED - dest[i].type = scheme_rt_compile_info; -#endif - dest[i].comp = 1; - dest[i].dont_mark_local_use = src[drec].dont_mark_local_use; - dest[i].resolve_module_ids = src[drec].resolve_module_ids; - dest[i].no_module_cert = src[drec].no_module_cert; - dest[i].value_name = scheme_false; - dest[i].certs = src[drec].certs; - /* should be always NULL */ - dest[i].observer = src[drec].observer; - dest[i].pre_unwrapped = 0; - dest[i].env_already = 0; - dest[i].comp_flags = src[drec].comp_flags; - } -} - -void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, - Scheme_Expand_Info *dest, int n) -{ - int i; - - for (i = 0; i < n; i++) { -#ifdef MZTAG_REQUIRED - dest[i].type = scheme_rt_compile_info; -#endif - dest[i].comp = 0; - dest[i].depth = src[drec].depth; - dest[i].value_name = scheme_false; - dest[i].certs = src[drec].certs; - dest[i].observer = src[drec].observer; - dest[i].pre_unwrapped = 0; - dest[i].no_module_cert = src[drec].no_module_cert; - dest[i].env_already = 0; - dest[i].comp_flags = src[drec].comp_flags; - } -} - -void scheme_merge_compile_recs(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *dest, int n) -{ - /* Nothing to do anymore, since we moved max_let_depth to resolve phase */ -} - -void scheme_init_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec) -{ -#ifdef MZTAG_REQUIRED - lam[dlrec].type = scheme_rt_compile_info; -#endif - lam[dlrec].comp = 1; - lam[dlrec].dont_mark_local_use = src[drec].dont_mark_local_use; - lam[dlrec].resolve_module_ids = src[drec].resolve_module_ids; - lam[dlrec].no_module_cert = src[drec].no_module_cert; - lam[dlrec].value_name = scheme_false; - lam[dlrec].certs = src[drec].certs; - lam[dlrec].observer = src[drec].observer; - lam[dlrec].pre_unwrapped = 0; - lam[dlrec].env_already = 0; - lam[dlrec].comp_flags = src[drec].comp_flags; -} - -void scheme_merge_lambda_rec(Scheme_Compile_Info *src, int drec, - Scheme_Compile_Info *lam, int dlrec) -{ -} - -void scheme_compile_rec_done_local(Scheme_Compile_Info *rec, int drec) -{ - rec[drec].value_name = scheme_false; -} - -void scheme_rec_add_certs(Scheme_Compile_Expand_Info *src, int drec, Scheme_Object *stx) -{ - Scheme_Object *certs; - certs = scheme_stx_extract_certs(stx, src[drec].certs); - src[drec].certs = certs; -} - -/*========================================================================*/ -/* compilation dispatcher */ -/*========================================================================*/ - -static Scheme_Object * -scheme_inner_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, int start_app_position) -{ - int len; - - len = scheme_stx_proper_list_length(form); - - if (!len) { - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - return scheme_null; - } else if (len > 0) { - Scheme_Compile_Info *recs, quick[5]; - int i; - Scheme_Object *c, *p, *comp_first, *comp_last, *name, *first, *rest; - - name = rec[drec].value_name; - scheme_compile_rec_done_local(rec, drec); - - if (len <= 5) - recs = quick; - else - recs = MALLOC_N_RT(Scheme_Compile_Info, len); - scheme_init_compile_recs(rec, drec, recs, len); - recs[len - 1].value_name = name; - - comp_first = comp_last = NULL; - - for (i = 0, rest = form; i < len; i++) { - first = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - - c = scheme_compile_expand_expr(first, env, recs, i, - !i && start_app_position); - - p = scheme_make_pair(c, scheme_null); - if (comp_last) - SCHEME_CDR(comp_last) = p; - else - comp_first = p; - comp_last = p; - } - - scheme_merge_compile_recs(rec, drec, recs, len); - - return comp_first; - } else { - scheme_signal_error("internal error: compile-list on non-list"); - return NULL; - } -} - -static Scheme_Object *compile_application(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *result; - int len; - - len = scheme_stx_proper_list_length(form); - - if (len < 0) - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, NULL); - - scheme_compile_rec_done_local(rec, drec); - scheme_rec_add_certs(rec, drec, form); - form = scheme_inner_compile_list(form, scheme_no_defines(env), rec, drec, 1); - - result = make_application(form); - - return result; -} - -Scheme_Object * -scheme_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return scheme_inner_compile_list(form, env, rec, drec, 0); -} - -static Scheme_Object *call_compile_handler(Scheme_Object *form, int immediate_eval) -{ - Scheme_Object *argv[2], *o; - - argv[0] = form; - argv[1] = (immediate_eval ? scheme_true : scheme_false); - o = scheme_get_param(scheme_current_config(), MZCONFIG_COMPILE_HANDLER); - o = scheme_apply(o, 2, argv); - - if (!SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) { - argv[0] = o; - scheme_wrong_type("compile-handler", "compiled code", 0, -1, argv); - return NULL; - } - - return o; -} - -static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env *genv) -{ - if (genv->rename_set) { - if (SCHEME_STX_PAIRP(form)) { - Scheme_Object *a, *d, *module_stx; - - a = SCHEME_STX_CAR(form); - if (SCHEME_STX_SYMBOLP(a)) { - a = scheme_add_rename(a, genv->rename_set); - module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), - scheme_false, - scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), - 0, 0); - if (scheme_stx_module_eq(a, module_stx, genv->phase)) { - /* Don't add renames to the whole module; let the - module's language take over. */ - d = SCHEME_STX_CDR(form); - a = scheme_make_pair(a, d); - form = scheme_datum_to_syntax(a, form, form, 0, 1); - return form; - } - } - } - } - - if (genv->rename_set) { - form = scheme_add_rename(form, genv->rename_set); - /* this "phase shift" just attaches the namespace's module registry: */ - form = scheme_stx_phase_shift(form, 0, NULL, NULL, genv->module_registry->exports); - } - - return form; -} - -static int get_comp_flags(Scheme_Config *config) -{ - int comp_flags = 0; - - if (!config) - config = scheme_current_config(); - - if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), - MZCONFIG_ALLOW_SET_UNDEFINED))) - comp_flags |= COMP_ALLOW_SET_UNDEFINED; - if (SCHEME_FALSEP(scheme_get_param(scheme_current_config(), - MZCONFIG_DISALLOW_INLINE))) - comp_flags |= COMP_CAN_INLINE; - - return comp_flags; -} - -void scheme_enable_expression_resolve_lifts(Resolve_Info *ri) -{ - Scheme_Object *lift_vec; - - lift_vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; - SCHEME_VEC_ELS(lift_vec)[1] = scheme_make_integer(0); - ri->lifts = lift_vec; -} - -Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri) -{ - Scheme_Object *lift_vec, *lifts; - Scheme_Sequence *s; - int n, i; - - lift_vec = ri->lifts; - n = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); - if (n) { - rp->num_lifts = n; - lifts = SCHEME_VEC_ELS(lift_vec)[0]; - - s = malloc_sequence(n + 1); - s->so.type = scheme_sequence_type; - s->count = n + 1; - for (i = 0; i < n; i++, lifts = SCHEME_CDR(lifts)) { - s->array[i] = SCHEME_CAR(lifts); - } - s->array[i] = expr; - - return (Scheme_Object *)s; - } else - return expr; -} - -static void *compile_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form; - int writeable, for_eval, rename, enforce_consts, comp_flags; - Scheme_Env *genv; - Scheme_Compile_Info rec, rec2; - Scheme_Object *o, *rl, *tl_queue; - Scheme_Compilation_Top *top; - Resolve_Prefix *rp; - Resolve_Info *ri; - Optimize_Info *oi; - Scheme_Object *gval, *insp; - Scheme_Comp_Env *cenv; - - form = (Scheme_Object *)p->ku.k.p1; - genv = (Scheme_Env *)p->ku.k.p2; - writeable = p->ku.k.i1; - for_eval = p->ku.k.i2; - rename = p->ku.k.i3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - if (!SCHEME_STXP(form)) { - form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); - rename = 1; - } - - /* Renamings for requires: */ - if (rename) { - form = add_renames_unless_module(form, genv); - if (genv->module) { - form = scheme_stx_phase_shift(form, 0, - genv->module->me->src_modidx, - genv->module->self_modidx, - genv->module_registry->exports); - } - } - - tl_queue = scheme_null; - - { - Scheme_Config *config; - config = scheme_current_config(); - insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); - enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); - comp_flags = get_comp_flags(config); - } - - while (1) { - scheme_prepare_compile_env(genv); - - rec.comp = 1; - rec.dont_mark_local_use = 0; - rec.resolve_module_ids = !writeable && !genv->module; - rec.no_module_cert = 0; - rec.value_name = scheme_false; - rec.certs = NULL; - rec.observer = NULL; - rec.pre_unwrapped = 0; - rec.env_already = 0; - rec.comp_flags = comp_flags; - - cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME); - - if (for_eval) { - /* Need to look for top-level `begin', and if we - find one, break it up to eval first expression - before the rest. */ - while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_false, scheme_null, scheme_false); - form = scheme_check_immediate_macro(form, - cenv, &rec, 0, - 0, &gval, NULL, NULL); - if (SAME_OBJ(gval, scheme_begin_syntax)) { - if (scheme_stx_proper_list_length(form) > 1){ - form = SCHEME_STX_CDR(form); - tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL), - tl_queue); - tl_queue = scheme_append(scheme_frame_get_lifts(cenv), - tl_queue); - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } else - break; - } else { - rl = scheme_frame_get_require_lifts(cenv); - o = scheme_frame_get_lifts(cenv); - if (!SCHEME_NULLP(o) - || !SCHEME_NULLP(rl)) { - tl_queue = scheme_make_pair(form, tl_queue); - tl_queue = scheme_append(o, tl_queue); - tl_queue = scheme_append(rl, tl_queue); - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } - break; - } - } - } - - if (for_eval) { - o = call_compile_handler(form, 1); - top = (Scheme_Compilation_Top *)o; - } else { - /* We want to simply compile `form', but we have to loop in case - an expression is lifted in the process of compiling: */ - Scheme_Object *l, *prev_o = NULL; - - while (1) { - scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), - scheme_false, scheme_false, scheme_null, scheme_false); - - scheme_init_compile_recs(&rec, 0, &rec2, 1); - - o = scheme_compile_expr(form, cenv, &rec2, 0); - - /* If we had compiled an expression in a previous iteration, - combine it in a sequence: */ - if (prev_o) { - Scheme_Sequence *seq; - seq = malloc_sequence(2); - seq->so.type = scheme_sequence_type; - seq->count = 2; - seq->array[0] = o; - seq->array[1] = prev_o; - o = (Scheme_Object *)seq; - } - - /* If any definitions were lifted in the process of compiling o, - we need to fold them in. */ - l = scheme_frame_get_lifts(cenv); - rl = scheme_frame_get_require_lifts(cenv); - if (!SCHEME_NULLP(l) - || !SCHEME_NULLP(rl)) { - rl = scheme_append(rl, l); - rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0), - rl); - form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0); - prev_o = o; - } else - break; - } - - oi = scheme_optimize_info_create(); - oi->enforce_const = enforce_consts; - if (!(comp_flags & COMP_CAN_INLINE)) - oi->inline_fuel = -1; - o = scheme_optimize_expr(o, oi, 0); - - rp = scheme_resolve_prefix(0, cenv->prefix, 1); - ri = scheme_resolve_info_create(rp); - ri->enforce_const = enforce_consts; - scheme_enable_expression_resolve_lifts(ri); - - o = scheme_resolve_expr(o, ri); - o = scheme_sfs(o, NULL, ri->max_let_depth); - - o = scheme_merge_expression_resolve_lifts(o, rp, ri); - - rp = scheme_remap_prefix(rp, ri); - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->so.type = scheme_compilation_top_type; - top->max_let_depth = ri->max_let_depth; - top->code = o; - top->prefix = rp; - - if (0) { /* <- change to 1 to check compilation result */ - scheme_validate_code(NULL, top->code, - top->max_let_depth, - top->prefix->num_toplevels, - top->prefix->num_stxes, - top->prefix->num_lifts, - NULL, - 0); - } - } - - if (SCHEME_PAIRP(tl_queue)) { - /* This compile is interleaved with evaluation, - and we need to eval now before compiling more. */ - _eval_compiled_multi_with_prompt((Scheme_Object *)top, genv); - - form = SCHEME_CAR(tl_queue); - tl_queue = SCHEME_CDR(tl_queue); - } else - break; - } - - return (void *)top; -} - -static Scheme_Object *_compile(Scheme_Object *form, Scheme_Env *env, int writeable, int for_eval, int eb, int rename) -{ - Scheme_Thread *p = scheme_current_thread; - - if (SAME_TYPE(SCHEME_TYPE(form), scheme_compilation_top_type)) - return form; - - if (SCHEME_STXP(form)) { - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) - return SCHEME_STX_VAL(form); - } - - p->ku.k.p1 = form; - p->ku.k.p2 = env; - p->ku.k.i1 = writeable; - p->ku.k.i2 = for_eval; - p->ku.k.i3 = rename; - - return (Scheme_Object *)scheme_top_level_do(compile_k, eb); -} - -Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable) -{ - return _compile(form, env, writeable, 0, 1, 1); -} - -Scheme_Object *scheme_compile_for_eval(Scheme_Object *form, Scheme_Env *env) -{ - return _compile(form, env, 0, 1, 1, 1); -} - -Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, - Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int internel_def_pos, - Scheme_Object **current_val, - Scheme_Comp_Env **_xenv, - Scheme_Object *ctx) -{ - Scheme_Object *name, *val, *certs; - Scheme_Comp_Env *xenv = (_xenv ? *_xenv : NULL); - Scheme_Expand_Info erec1; - Scheme_Env *menv = NULL; - int need_cert; - - SCHEME_EXPAND_OBSERVE_ENTER_CHECK(rec[drec].observer, first); - - while (1) { - *current_val = NULL; - - if (SCHEME_STX_PAIRP(first)) { - name = SCHEME_STX_CAR(first); - need_cert = 1; - } else { - name = first; - need_cert = 0; - } - - if (!SCHEME_STX_SYMBOLP(name)) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); - return first; - } - - while (1) { - - if (need_cert) { - /* While resolving name, we need certs from `first' */ - scheme_init_expand_recs(rec, drec, &erec1, 1); - scheme_rec_add_certs(&erec1, 0, first); - certs = erec1.certs; - } else - certs = rec[drec].certs; - - val = scheme_lookup_binding(name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? SCHEME_OUT_OF_CONTEXT_OK - : 0) - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0), - certs, env->in_modidx, - &menv, NULL, NULL); - - if (SCHEME_STX_PAIRP(first)) - *current_val = val; - - if (!val) { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); - return first; - } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { - if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) { - /* It's a rename. Look up the target name and try again. */ - name = scheme_transfer_srcloc(scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), - scheme_false, menv, name, NULL, 1), - name); - menv = NULL; - SCHEME_USE_FUEL(1); - } else { - /* It's a normal macro; expand once. Also, extend env to indicate - an internal-define position, if necessary. */ - if (!xenv) { - if (internel_def_pos) { - xenv = scheme_new_compilation_frame(0, SCHEME_INTDEF_FRAME, env, NULL); - if (ctx) - xenv->intdef_name = ctx; - if (_xenv) - *_xenv = xenv; - } else - xenv = env; - } - { - scheme_init_expand_recs(rec, drec, &erec1, 1); - erec1.depth = 1; - erec1.value_name = rec[drec].value_name; - first = scheme_expand_expr(first, xenv, &erec1, 0); - } - break; /* break to outer loop */ - } - } else { - SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); - return first; - } - } - } -} - -static Scheme_Object * -compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *macro, - Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) -{ - Scheme_Object *xformer, *boundname; - - xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro); - - if (scheme_is_set_transformer(xformer)) { - /* scheme_apply_macro unwraps it */ - } else { - if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) { - scheme_wrong_syntax(NULL, NULL, form, "illegal use of syntax"); - return NULL; - } - } - - boundname = rec[drec].value_name; - if (!boundname) - boundname = scheme_false; - - return scheme_apply_macro(name, menv, xformer, form, env, boundname, rec, drec, 0); - - /* caller expects rec[drec] to be used to compile the result... */ -} - -static int same_effective_env(Scheme_Comp_Env *orig, Scheme_Comp_Env *e) -{ - while (1) { - if (orig == e) - return 1; - if (e && e->flags & SCHEME_FOR_STOPS) - e = e->next; - else - return 0; - } -} - -static Scheme_Object *compile_expand_expr_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; - Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return scheme_compile_expand_expr(form, - env, - rec, - p->ku.k.i3, - p->ku.k.i2); -} - -static Scheme_Object * -scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int app_position) -{ - Scheme_Object *name, *var, *stx, *normal, *can_recycle_stx = NULL, *orig_unbound_name = NULL; - Scheme_Env *menv = NULL; - GC_CAN_IGNORE char *not_allowed; - int looking_for_top, has_orig_unbound = 0; - - top: - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - Scheme_Compile_Expand_Info *recx; - - recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); -#ifdef MZTAG_REQUIRED - recx->type = scheme_rt_compile_info; -#endif - - p->ku.k.p1 = (void *)form; - p->ku.k.p2 = (void *)env; - p->ku.k.p3 = (void *)recx; - p->ku.k.i3 = 0; - p->ku.k.i2 = app_position; - - var = scheme_handle_stack_overflow(compile_expand_expr_k); - - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - return var; - } - } -#endif - - DO_CHECK_FOR_BREAK(scheme_current_thread, ;); - -#if 1 - if (!SCHEME_STXP(form)) - scheme_signal_error("not syntax"); -#endif - - if (rec[drec].comp) { - scheme_default_compile_rec(rec, drec); - } else { - SCHEME_EXPAND_OBSERVE_VISIT(rec[drec].observer,form); - } - - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_expanded_syntax_type)) { - var = SCHEME_STX_VAL(form); - if (scheme_stx_has_empty_wraps(form) - && same_effective_env(SCHEME_PTR2_VAL(var), env)) { - /* FIXME: this needs EXPAND_OBSERVE callbacks. */ - var = scheme_stx_track(SCHEME_PTR1_VAL(var), form, form); - form = scheme_stx_cert(var, scheme_false, NULL, form, NULL, 1); - if (!rec[drec].comp && (rec[drec].depth != -1)) { - /* Already fully expanded. */ - return form; - } - } else { - scheme_wrong_syntax(NULL, NULL, SCHEME_PTR1_VAL(var), - "expanded syntax not in its original lexical context" - " (extra bindings or marks in the current context)"); - } - } - - looking_for_top = 0; - - if (SCHEME_STX_NULLP(form)) { - stx = app_symbol; - not_allowed = "function application"; - normal = app_expander; - } else if (!SCHEME_STX_PAIRP(form)) { - if (SCHEME_STX_SYMBOLP(form)) { - Scheme_Object *find_name = form, *lexical_binding_id; - int protected = 0; - - while (1) { - lexical_binding_id = NULL; - var = scheme_lookup_binding(find_name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_ENV_CONSTANTS_OK - + (rec[drec].comp - ? SCHEME_ELIM_CONST - : 0) - + (app_position - ? SCHEME_APP_POS - : 0) - + ((rec[drec].comp && rec[drec].dont_mark_local_use) ? - SCHEME_DONT_MARK_USE - : 0) - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0), - rec[drec].certs, env->in_modidx, - &menv, &protected, &lexical_binding_id); - - SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name); - - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - protected = 0; - } else - break; - } - - if (!var) { - /* Top variable */ - stx = top_symbol; - if (env->genv->module) - not_allowed = "reference to an unbound identifier"; - else - not_allowed = "reference to a top-level identifier"; - normal = top_expander; - has_orig_unbound = 1; - form = find_name; /* in case it was re-mapped */ - looking_for_top = 1; - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { - if (var == stop_expander) { - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer,form); - SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer,form); - SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer,form); - return form; - } else { - scheme_wrong_syntax(NULL, NULL, form, "bad syntax"); - return NULL; - } - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - name = form; - goto macro; - } - - if (rec[drec].comp) { - scheme_compile_rec_done_local(rec, drec); - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - && scheme_extract_unsafe(var)) { - scheme_register_unsafe_in_prefix(env, rec, drec, menv); - return scheme_extract_unsafe(var); - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - && scheme_extract_flfxnum(var)) { - return scheme_extract_flfxnum(var); - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - && scheme_extract_futures(var)) { - return scheme_extract_futures(var); - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) - return scheme_register_toplevel_in_prefix(var, env, rec, drec, - scheme_is_imported(var, env)); - else - return var; - } else { - SCHEME_EXPAND_OBSERVE_VARIABLE(rec[drec].observer, form, find_name); - if (lexical_binding_id) { - find_name = lexical_binding_id; - } - if (protected) { - /* Add a property to indicate that the name is protected */ - find_name = scheme_stx_property(find_name, protected_symbol, scheme_true); - } - SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, find_name); - return find_name; /* which is usually == form */ - } - } - } else { - /* A hack for handling lifted expressions. See compile_expand_lift_to_let. */ - if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_already_comp_type)) { - form = SCHEME_STX_VAL(form); - return SCHEME_IPTR_VAL(form); - } - - stx = datum_symbol; - not_allowed = "literal data"; - normal = datum_expander; - } - } else { - name = SCHEME_STX_CAR(form); - if (SCHEME_STX_SYMBOLP(name)) { - /* Check for macros: */ - Scheme_Object *find_name = name; - Scheme_Expand_Info erec1; - - /* While resolving name, we need certs from `form' */ - scheme_init_expand_recs(rec, drec, &erec1, 1); - scheme_rec_add_certs(&erec1, 0, form); - - while (1) { - var = scheme_lookup_binding(find_name, env, - SCHEME_APP_POS - + SCHEME_NULL_FOR_UNBOUND - + SCHEME_ENV_CONSTANTS_OK - + (rec[drec].comp - ? SCHEME_ELIM_CONST - : 0) - + SCHEME_DONT_MARK_USE - + ((rec[drec].comp && rec[drec].resolve_module_ids) - ? SCHEME_RESOLVE_MODIDS - : 0) - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0), - erec1.certs, env->in_modidx, - &menv, NULL, NULL); - - SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } - - if (!var) { - /* apply to global variable: compile it normally */ - orig_unbound_name = find_name; - has_orig_unbound = 1; - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) { - /* apply to local variable: compile it normally */ - } else { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - goto macro; - } else if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { - if (rec[drec].comp) { - Scheme_Syntax *f; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - return f(form, env, rec, drec); - } else { - Scheme_Syntax_Expander *f; - f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form); - form = f(form, env, rec, drec); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); - return form; - } - } - - /* Else: unknown global - must be a function: compile as application */ - } - - if (!SAME_OBJ(name, find_name)) { - /* the rator position was mapped */ - Scheme_Object *code; - code = SCHEME_STX_CDR(form); - code = scheme_make_pair(find_name, code); - form = scheme_datum_to_syntax(code, form, form, 0, 0); - } - } - - stx = app_symbol; - not_allowed = "function application"; - normal = app_expander; - } - - /* Compile/expand as application, datum, or top: */ - if (quick_stx && rec[drec].comp) { - ((Scheme_Stx *)quick_stx)->val = stx; - ((Scheme_Stx *)quick_stx)->wraps = ((Scheme_Stx *)form)->wraps; - ((Scheme_Stx *)quick_stx)->u.modinfo_cache = NULL; - stx = quick_stx; - quick_stx = NULL; - } else - stx = scheme_datum_to_syntax(stx, scheme_false, form, 0, 0); - if (rec[drec].comp) - can_recycle_stx = stx; - - { - Scheme_Object *find_name = stx; - - while (1) { - var = scheme_lookup_binding(find_name, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0), - rec[drec].certs, env->in_modidx, - &menv, NULL, NULL); - - SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); - - if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - /* It's a rename. Look up the target name and try again. */ - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); - if (!rec[drec].comp) { - new_name = scheme_stx_track(new_name, find_name, find_name); - } - new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); - find_name = scheme_transfer_srcloc(new_name, find_name); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } - } - - if (!SAME_OBJ(var, normal)) { - /* Someone might keep the stx: */ - can_recycle_stx = NULL; - } - - if (!var && looking_for_top) { - /* If form is a marked name, then force #%top binding. - This is so temporaries can be used as defined ids. */ - Scheme_Object *nm; - nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL, NULL); - if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) { - stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); - - /* Should be either top_expander or stop_expander: */ - var = scheme_lookup_binding(stx, env, - SCHEME_NULL_FOR_UNBOUND - + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK - + SCHEME_DONT_MARK_USE - + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) - : 0), - rec[drec].certs, env->in_modidx, - &menv, NULL, NULL); - } - } - - if (var && (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type))) { - if (SAME_OBJ(var, stop_expander)) { - /* Return original: */ - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form); - SCHEME_EXPAND_OBSERVE_PRIM_STOP(rec[drec].observer); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); - return form; - } else if (rec[drec].comp && SAME_OBJ(var, normal) && !rec[drec].observer) { - /* Skip creation of intermediate form */ - Scheme_Syntax *f; - rec[drec].pre_unwrapped = 1; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - if (can_recycle_stx && !quick_stx) - quick_stx = can_recycle_stx; - return f(form, env, rec, drec); - } else { - form = scheme_datum_to_syntax(scheme_make_pair(stx, form), form, form, 0, 2); - SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer, form); - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { - if (rec[drec].comp) { - Scheme_Syntax *f; - f = (Scheme_Syntax *)SCHEME_SYNTAX(var); - return f(form, env, rec, drec); - } else { - Scheme_Syntax_Expander *f; - f = (Scheme_Syntax_Expander *)SCHEME_SYNTAX_EXP(var); - SCHEME_EXPAND_OBSERVE_ENTER_PRIM(rec[drec].observer, form); - form = f(form, env, rec, drec); - SCHEME_EXPAND_OBSERVE_EXIT_PRIM(rec[drec].observer, form); - SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); - return form; - } - } else { - name = stx; - goto macro; - } - } - } else { - /* Not allowed this context! */ - char *phase, buf[30]; - if (env->genv->phase == 0) - phase = ""; - else if (env->genv->phase == 1) - phase = " in the transformer environment"; - else { - phase = buf; - sprintf(buf, " at phase %" PRIdPTR, env->genv->phase); - } - if (has_orig_unbound) { - scheme_wrong_syntax(scheme_compile_stx_string, - orig_unbound_name, form, - "unbound identifier%s " - "(and no %S syntax transformer is bound)", - phase, - SCHEME_STX_VAL(stx)); - } else { - scheme_wrong_syntax(scheme_compile_stx_string, NULL, form, - "bad syntax; %s is not allowed, " - "because no %S syntax transformer is bound%s", - not_allowed, - SCHEME_STX_VAL(stx), - phase); - } - return NULL; - } - - macro: - if (!rec[drec].comp && !rec[drec].depth) { - SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); - return form; /* We've gone as deep as requested */ - } - - SCHEME_EXPAND_OBSERVE_ENTER_MACRO(rec[drec].observer, form); - form = compile_expand_macro_app(name, menv, var, form, env, rec, drec); - SCHEME_EXPAND_OBSERVE_EXIT_MACRO(rec[drec].observer, form); - - if (rec[drec].comp) - goto top; - else { - if (rec[drec].depth > 0) - --rec[drec].depth; - if (rec[drec].depth) - goto top; - else { - SCHEME_EXPAND_OBSERVE_RETURN(rec[drec].observer, form); - return form; - } - } -} - -static int arg_count(Scheme_Object *lam, Scheme_Comp_Env *env) -{ - Scheme_Object *l, *id, *form = lam; - int cnt = 0; - DupCheckRecord r; - - lam = SCHEME_STX_CDR(lam); - if (!SCHEME_STX_PAIRP(lam)) return -1; - - l = SCHEME_STX_CAR(lam); - - lam = SCHEME_STX_CDR(lam); - if (!SCHEME_STX_PAIRP(lam)) return -1; - - while (SCHEME_STX_PAIRP(lam)) { lam = SCHEME_STX_CDR(lam); } - if (!SCHEME_STX_NULLP(lam)) return -1; - - - scheme_begin_dup_symbol_check(&r, env); - - while (SCHEME_STX_PAIRP(l)) { - id = SCHEME_STX_CAR(l); - scheme_check_identifier("lambda", id, NULL, env, form); - scheme_dup_symbol_check(&r, NULL, id, "argument", form); - l = SCHEME_STX_CDR(l); - cnt++; - } - if (!SCHEME_STX_NULLP(l)) return -1; - - return cnt; -} - -static Scheme_Object *cert_ids(Scheme_Object *orig_ids, Scheme_Object *orig) -{ - Scheme_Object *id, *ids = orig_ids, *pr, *first = scheme_null, *last = NULL; - - while (!SCHEME_STX_NULLP(ids)) { - - id = SCHEME_STX_CAR(ids); - id = scheme_stx_cert(id, NULL, NULL, orig, NULL, 1); - - pr = scheme_make_pair(id, scheme_null); - - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - ids = SCHEME_STX_CDR(ids); - } - - return scheme_datum_to_syntax(first, orig_ids, orig_ids, 0, 2); -} - -static Scheme_Object * -compile_expand_app(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec) -{ - Scheme_Object *form, *naya; - int tsc; - - tsc = rec[drec].pre_unwrapped; - rec[drec].pre_unwrapped = 0; - - scheme_rec_add_certs(rec, drec, forms); - if (tsc) { - form = forms; - } else { - form = SCHEME_STX_CDR(forms); - form = scheme_datum_to_syntax(form, forms, forms, 0, 0); - } - - if (SCHEME_STX_NULLP(form)) { - /* Compile/expand empty application to null list: */ - if (rec[drec].comp) - return scheme_null; - else - return scheme_datum_to_syntax(icons(quote_symbol, - icons(form, scheme_null)), - form, - scheme_sys_wraps(env), - 0, 2); - } else if (!SCHEME_STX_PAIRP(form)) { - /* will end in error */ - if (rec[drec].comp) - return compile_application(form, env, rec, drec); - else { - rec[drec].value_name = scheme_false; - naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec); - /* naya will be prefixed and returned... */ - } - } else if (rec[drec].comp) { - Scheme_Object *name, *origname, *gval, *orig_rest_form, *rest_form; - name = SCHEME_STX_CAR(form); - origname = name; - - name = scheme_check_immediate_macro(name, env, rec, drec, 0, &gval, NULL, NULL); - - /* look for ((lambda (x ...) ....) ....) or ((lambda x ....) ....) */ - if (SAME_OBJ(gval, scheme_lambda_syntax)) { - Scheme_Object *argsnbody; - - argsnbody = SCHEME_STX_CDR(name); - if (SCHEME_STX_PAIRP(argsnbody)) { - Scheme_Object *args, *body; - - args = SCHEME_STX_CAR(argsnbody); - body = SCHEME_STX_CDR(argsnbody); - - if (SCHEME_STX_PAIRP(body)) { - int pl; - pl = scheme_stx_proper_list_length(args); - if ((pl >= 0) || SCHEME_STX_SYMBOLP(args)) { - Scheme_Object *bindings = scheme_null, *last = NULL; - Scheme_Object *rest; - int al; - - rest = SCHEME_STX_CDR(form); - al = scheme_stx_proper_list_length(rest); - - if ((pl < 0) || (al == pl)) { - DupCheckRecord r; - - scheme_begin_dup_symbol_check(&r, env); - - while (!SCHEME_STX_NULLP(args)) { - Scheme_Object *v, *n; - - if (pl < 0) - n = args; - else - n = SCHEME_STX_CAR(args); - scheme_check_identifier("lambda", n, NULL, env, name); - - /* If we don't check here, the error is in terms of `let': */ - scheme_dup_symbol_check(&r, NULL, n, "argument", name); - - /* Propagate certifications to bound id: */ - n = scheme_stx_cert(n, NULL, NULL, name, NULL, 1); - - if (pl < 0) { - v = scheme_intern_symbol("list"); - v = scheme_datum_to_syntax(v, scheme_false, scheme_sys_wraps(env), 0, 0); - v = cons(v, rest); - } else - v = SCHEME_STX_CAR(rest); - v = cons(cons(cons(n, scheme_null), cons(v, scheme_null)), scheme_null); - if (last) - SCHEME_CDR(last) = v; - else - bindings = v; - - last = v; - if (pl < 0) { - /* rator is (lambda rest-x ....) */ - break; - } else { - args = SCHEME_STX_CDR(args); - rest = SCHEME_STX_CDR(rest); - } - } - - body = scheme_datum_to_syntax(icons(begin_symbol, body), form, - scheme_sys_wraps(env), - 0, 2); - /* Copy certifications from lambda to `body'. */ - body = scheme_stx_cert(body, NULL, NULL, name, NULL, 1); - - body = scheme_datum_to_syntax(cons(let_values_symbol, - cons(bindings, - cons(body, scheme_null))), - form, - scheme_sys_wraps(env), - 0, 2); - - return scheme_compile_expand_expr(body, env, rec, drec, 0); - } else { -#if 0 - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, - "procedure application: bad ((lambda (...) ...) ...) syntax"); - return NULL; -#endif - } - } - } - } - } - - orig_rest_form = SCHEME_STX_CDR(form); - - /* Look for (call-with-values (lambda () M) (lambda (id ...) N)) */ - if (SCHEME_STX_SYMBOLP(name)) { - Scheme_Object *at_first, *at_second, *the_end, *cwv_stx; - at_first = SCHEME_STX_CDR(form); - if (SCHEME_STX_PAIRP(at_first)) { - at_second = SCHEME_STX_CDR(at_first); - if (SCHEME_STX_PAIRP(at_second)) { - the_end = SCHEME_STX_CDR(at_second); - if (SCHEME_STX_NULLP(the_end)) { - Scheme_Object *orig_at_second = at_second; - - cwv_stx = scheme_datum_to_syntax(scheme_intern_symbol("call-with-values"), - scheme_false, scheme_sys_wraps(env), 0, 0); - if (scheme_stx_module_eq(name, cwv_stx, 0)) { - Scheme_Object *first, *orig_first; - orig_first = SCHEME_STX_CAR(at_first); - first = scheme_check_immediate_macro(orig_first, env, rec, drec, 0, &gval, NULL, NULL); - if (SAME_OBJ(gval, scheme_lambda_syntax) - && SCHEME_STX_PAIRP(first) - && (arg_count(first, env) == 0)) { - Scheme_Object *second, *orig_second; - orig_second = SCHEME_STX_CAR(at_second); - second = scheme_check_immediate_macro(orig_second, env, rec, drec, 0, &gval, NULL, NULL); - if (SAME_OBJ(gval, scheme_lambda_syntax) - && SCHEME_STX_PAIRP(second) - && (arg_count(second, env) >= 0)) { - Scheme_Object *lhs, *orig_post_first, *orig_post_second; - orig_post_first = first; - orig_post_second = second; - second = SCHEME_STX_CDR(second); - lhs = SCHEME_STX_CAR(second); - second = SCHEME_STX_CDR(second); - first = SCHEME_STX_CDR(first); - first = SCHEME_STX_CDR(first); - first = icons(begin_symbol, first); - first = scheme_datum_to_syntax(first, orig_post_first, scheme_sys_wraps(env), 0, 1); - second = icons(begin_symbol, second); - second = scheme_datum_to_syntax(second, orig_post_second, scheme_sys_wraps(env), 0, 1); - /* Copy certifications from lambda to body: */ - lhs = cert_ids(lhs, orig_post_second); - first = scheme_stx_cert(first, NULL, NULL, orig_post_first, NULL, 1); - second = scheme_stx_cert(second, NULL, NULL, orig_post_second, NULL, 1); - /* Convert to let-values: */ - name = icons(let_values_symbol, - icons(icons(icons(lhs, icons(first, scheme_null)), - scheme_null), - icons(second, scheme_null))); - form = scheme_datum_to_syntax(name, forms, scheme_sys_wraps(env), 0, 2); - return scheme_compile_expand_expr(form, env, rec, drec, 0); - } - if (!SAME_OBJ(second, orig_second)) { - at_second = scheme_datum_to_syntax(icons(second, the_end), at_second, at_second, 0, 2); - } - } - if (!SAME_OBJ(first, orig_first) - || !SAME_OBJ(at_second, orig_at_second)) { - at_first = scheme_datum_to_syntax(icons(first, at_second), at_first, at_first, 0, 2); - } - } - } - } - } - rest_form = at_first; - } else { - rest_form = orig_rest_form; - } - - if (NOT_SAME_OBJ(name, origname) - || NOT_SAME_OBJ(rest_form, orig_rest_form)) { - form = scheme_datum_to_syntax(scheme_make_pair(name, rest_form), forms, forms, 0, 2); - } - - return compile_application(form, env, rec, drec); - } else { - scheme_rec_add_certs(rec, drec, form); - rec[drec].value_name = scheme_false; - naya = scheme_expand_list(form, scheme_no_defines(env), rec, drec); - /* naya will be prefixed returned... */ - } - - if (SAME_OBJ(form, naya)) - return forms; - - /* Add #%app prefix back: */ - { - Scheme_Object *first; - - first = SCHEME_STX_CAR(forms); - return scheme_datum_to_syntax(scheme_make_pair(first, naya), - forms, - forms, 0, 2); - } -} - -static Scheme_Object * -app_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_app(form, env, rec, drec); -} - -static Scheme_Object * -app_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_APP(erec[drec].observer); - return compile_expand_app(form, env, erec, drec); -} - -static Scheme_Object * -datum_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *c, *v; - - if (rec[drec].pre_unwrapped) { - c = form; - rec[drec].pre_unwrapped = 0; - } else { - c = SCHEME_STX_CDR(form); - /* Need datum->syntax, in case c is a list: */ - c = scheme_datum_to_syntax(c, form, form, 0, 2); - } - - v = SCHEME_STX_VAL(c); - if (SCHEME_KEYWORDP(v)) { - scheme_wrong_syntax("#%datum", NULL, c, "keyword used as an expression"); - return NULL; - } - - return scheme_syntax_to_datum(c, 0, NULL); -} - -static Scheme_Object * -datum_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *rest, *v; - - SCHEME_EXPAND_OBSERVE_PRIM_DATUM(erec[drec].observer); - - rest = SCHEME_STX_CDR(form); - - v = SCHEME_STX_VAL(rest); - if (SCHEME_KEYWORDP(v)) { - scheme_wrong_syntax("#%datum", NULL, rest, "keyword used as an expression"); - return NULL; - } - - return scheme_datum_to_syntax(icons(quote_symbol, - icons(rest, scheme_null)), - form, - scheme_sys_wraps(env), - 0, 2); -} - -static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *c; - - if (rec[drec].pre_unwrapped) { - c = form; - rec[drec].pre_unwrapped = 0; - } else - c = SCHEME_STX_CDR(form); - - if (!SCHEME_STX_SYMBOLP(c)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - - if (env->genv->module) { - Scheme_Object *modidx, *symbol = c, *tl_id; - int bad; - - tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL); - if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { - /* Since the module has a rename for this id, it's certainly defined. */ - } else { - modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL, NULL); - if (modidx) { - /* If it's an access path, resolve it: */ - if (env->genv->module - && SAME_OBJ(scheme_module_resolve(modidx, 1), env->genv->module->modname)) - bad = 0; - else - bad = 1; - } else - bad = 1; - - if (env->genv->disallow_unbound) { - if (bad || !scheme_lookup_in_table(env->genv->toplevel, (const char *)SCHEME_STX_SYM(c))) { - GC_CAN_IGNORE const char *reason; - if (env->genv->phase == 1) { - reason = "unbound identifier in module (in phase 1, transformer environment)"; - /* Check in the run-time environment */ - if (scheme_lookup_in_table(env->genv->template_env->toplevel, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the run-time definition)"); - } else if (env->genv->template_env->syntax - && scheme_lookup_in_table(env->genv->template_env->syntax, (const char *)SCHEME_STX_SYM(c))) { - reason = ("unbound identifier in module (in the transformer environment, which does" - " not include the macro definition that is visible to run-time expressions)"); - } - } else if (env->genv->phase == 0) - reason = "unbound identifier in module"; - else - reason = "unbound identifier in module (in phase %d)"; - scheme_wrong_syntax(when, NULL, c, reason, env->genv->phase); - } - } - } - } - - return c; -} - -static Scheme_Object * -top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *c; - - c = check_top(scheme_compile_stx_string, form, env, rec, drec); - - c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL); - - if (env->genv->module && !rec[drec].resolve_module_ids) { - /* Self-reference in a module; need to remember the modidx. Don't - need a pos, because the symbol's gensym-ness (if any) will be - preserved within the module. */ - c = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, - c, env->genv->module->insp, - -1, env->genv->mod_phase); - } else { - c = (Scheme_Object *)scheme_global_bucket(c, env->genv); - } - - return scheme_register_toplevel_in_prefix(c, env, rec, drec, 0); -} - -static Scheme_Object * -top_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_TOP(erec[drec].observer); - check_top(scheme_expand_stx_string, form, env, erec, drec); - return form; -} - -Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return scheme_compile_expand_expr(form, env, rec, drec, 0); -} - -Scheme_Object *scheme_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) -{ - return scheme_compile_expand_expr(form, env, erec, drec, 0); -} - -static Scheme_Object *pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, Scheme_Comp_Env *env) -{ - Scheme_Comp_Env **ip = (Scheme_Comp_Env **)_ip, *naya; - Scheme_Object *ids, *id; - int pos; - - pos = scheme_list_length(*_ids); - naya = scheme_new_compilation_frame(pos, SCHEME_CAPTURE_LIFTED, (*ip)->next, NULL); - (*ip)->next = naya; - *ip = naya; - - for (ids = *_ids; !SCHEME_NULLP(ids); ids = SCHEME_CDR(ids)) { - id = SCHEME_CAR(ids); - scheme_add_compilation_binding(--pos, id, naya); - } - - return icons(*_ids, icons(expr, scheme_null)); -} - -static Scheme_Object *add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, - Scheme_Object *orig_form, int comp_rev) -{ - Scheme_Object *revl, *a; - - if (SCHEME_NULLP(l)) return obj; - - revl = scheme_reverse(l); - - if (comp_rev) { - /* We've already compiled the body of this let - with the bindings in reverse order. So insert a series of `lets' - to match that order: */ - if (!SCHEME_NULLP(SCHEME_CDR(l))) { - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - a = scheme_reverse(SCHEME_CAR(SCHEME_CAR(l))); - for (; !SCHEME_NULLP(a); a = SCHEME_CDR(a)) { - obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - icons(icons(icons(icons(SCHEME_CAR(a), scheme_null), icons(SCHEME_CAR(a), scheme_null)), - scheme_null), - icons(obj, scheme_null))); - } - } - } - } - - for (; SCHEME_PAIRP(revl); revl = SCHEME_CDR(revl)) { - a = SCHEME_CAR(revl); - obj = icons(scheme_datum_to_syntax(let_values_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - icons(icons(a, scheme_null), - icons(obj, scheme_null))); - } - - obj = scheme_datum_to_syntax(obj, orig_form, scheme_false, 0, 0); - - return obj; -} - -static Scheme_Object *compile_expand_expr_lift_to_let_k(void); - -static Scheme_Object * -compile_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *rec, int drec) -{ - Scheme_Expand_Info recs[2]; - Scheme_Object *l, *orig_form = form, *context_key; - Scheme_Comp_Env *inserted, **ip; - - /* This function only works when `env' has no lexical bindings, - because we might insert new ones at the beginning. In - particular, we might insert frames between `inserted' and - `env'. - - This function also relies on the way that compilation of `let' - works. A let-bound variable is compiled to a count of the frames - to skip and the index within the frame, so we can insert new - frames without affecting lookups computed so far. Inserting each - new frame before any previous one turns out to be consistent with - the nested `let's that we generate at the end. - - Some optimizations can happen later, for example constant - propagate. But these optimizations take place on the result of - this function, so we don't have to worry about them. - - Don't generate a `let*' expression instead of nested `let's, - because the compiler actually takes shortcuts (that are - inconsistent with our frame nesting) instead of expanding `let*' - to `let'. */ - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - Scheme_Compile_Expand_Info *recx; - - recx = MALLOC_ONE_RT(Scheme_Compile_Expand_Info); - memcpy(recx, rec + drec, sizeof(Scheme_Compile_Expand_Info)); -#ifdef MZTAG_REQUIRED - recx->type = scheme_rt_compile_info; -#endif - - p->ku.k.p1 = (void *)form; - p->ku.k.p2 = (void *)env; - p->ku.k.p3 = (void *)recx; - - form = scheme_handle_stack_overflow(compile_expand_expr_lift_to_let_k); - - memcpy(rec + drec, recx, sizeof(Scheme_Compile_Expand_Info)); - return form; - } - } -#endif - - inserted = scheme_new_compilation_frame(0, 0, env, NULL); - - ip = MALLOC_N(Scheme_Comp_Env *, 1); - *ip = inserted; - - context_key = scheme_generate_lifts_key(); - - scheme_frame_captures_lifts(inserted, pair_lifted, (Scheme_Object *)ip, scheme_false, - context_key, NULL, scheme_false); - - if (rec[drec].comp) { - scheme_init_compile_recs(rec, drec, recs, 2); - form = scheme_compile_expr(form, inserted, recs, 0); - } else { - scheme_init_expand_recs(rec, drec, recs, 2); - form = scheme_expand_expr(form, inserted, recs, 0); - } - - l = scheme_frame_get_lifts(inserted); - if (SCHEME_NULLP(l)) { - /* No lifts */ - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, recs, 1); - return form; - } else { - /* We have lifts, so add let* wrapper and go again */ - Scheme_Object *o; - if (rec[drec].comp) { - /* Wrap compiled part so the compiler recognizes it later: */ - o = scheme_alloc_object(); - o->type = scheme_already_comp_type; - SCHEME_IPTR_VAL(o) = form; - } else - o = form; - form = add_lifts_as_let(o, l, env, orig_form, rec[drec].comp); - SCHEME_EXPAND_OBSERVE_LETLIFT_LOOP(rec[drec].observer, form); - form = compile_expand_expr_lift_to_let(form, env, recs, 1); - if (rec[drec].comp) - scheme_merge_compile_recs(rec, drec, recs, 2); - return form; - } -} - -static Scheme_Object *compile_expand_expr_lift_to_let_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = (Scheme_Object *)p->ku.k.p1; - Scheme_Comp_Env *env = (Scheme_Comp_Env *)p->ku.k.p2; - Scheme_Compile_Info *rec = (Scheme_Compile_Info *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - return compile_expand_expr_lift_to_let(form, env, rec, 0); -} - -Scheme_Object * -scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return compile_expand_expr_lift_to_let(form, env, rec, drec); -} - -Scheme_Object * -scheme_expand_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Expand_Info *erec, int drec) -{ - return compile_expand_expr_lift_to_let(form, env, erec, drec); -} - -static Scheme_Object * -scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Expand_Info *rec, int drec, - int mixed) -/* This ugly code parses a block of code, transforming embedded - define-values and define-syntax into letrec and letrec-syntax. - It is espcailly ugly because we have to expand macros - before deciding what we have. */ -{ - Scheme_Object *first, *rib, *ctx, *ectx, *orig = forms, *pre_exprs = scheme_null; - void **d; - Scheme_Comp_Env *xenv = NULL; - Scheme_Compile_Info recs[2]; - DupCheckRecord r; - - if (rec[drec].comp) { - scheme_default_compile_rec(rec, drec); - } else { - SCHEME_EXPAND_OBSERVE_ENTER_BLOCK(rec[drec].observer, forms); - } - - if (SCHEME_STX_NULLP(forms)) { - if (rec[drec].comp) { - scheme_compile_rec_done_local(rec, drec); - return scheme_null; - } else { - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms); - SCHEME_EXPAND_OBSERVE_ENTER_LIST(rec[drec].observer, forms); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(rec[drec].observer, forms); - return forms; - } - } - - rib = scheme_make_rename_rib(); - ctx = scheme_alloc_object(); - ctx->type = scheme_intdef_context_type; - d = MALLOC_N(void*, 3); - d[0] = env; - SCHEME_PTR1_VAL(ctx) = d; - SCHEME_PTR2_VAL(ctx) = rib; - ectx = scheme_make_pair(ctx, scheme_null); - scheme_begin_dup_symbol_check(&r, env); - - try_again: - - SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - - if (!SCHEME_STX_PAIRP(forms)) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax"); - return NULL; - } - - first = SCHEME_STX_CAR(forms); - - { - /* Need to send both parts (before & after) of block rename */ - Scheme_Object *old_first; - - old_first = first; - first = scheme_add_rename_rib(first, rib); - - SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first); - } - - { - Scheme_Object *gval, *result; - int more = 1; - - result = forms; - - /* Check for macro expansion, which could mask the real - define-values, define-syntax, etc.: */ - first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx); - - if (SAME_OBJ(gval, scheme_begin_syntax)) { - /* Inline content */ - Scheme_Object *orig_forms = forms; - - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer); - - /* FIXME: Redundant with check done by scheme_flatten_begin below? */ - if (scheme_stx_proper_list_length(first) < 0) - scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, - "bad syntax (" IMPROPER_LIST_FORM ")"); - - forms = SCHEME_STX_CDR(forms); - - if (SCHEME_STX_NULLP(forms)) { - /* A `begin' that ends the block. An `inferred-name' property - attached to this begin should apply to the ultimate last - thing in the block. */ - Scheme_Object *v; - v = scheme_check_name_property(first, rec[drec].value_name); - rec[drec].value_name = v; - } - - forms = scheme_flatten_begin(first, forms); - - SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer, forms); - - if (SCHEME_STX_NULLP(forms)) { - if (!SCHEME_PAIRP(pre_exprs)) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, first, - "bad syntax (empty form)"); - return NULL; - } else { - /* fall through to handle expressions without definitions */ - } - } else { - forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); - - goto try_again; - } - - forms = scheme_datum_to_syntax(forms, orig_forms, orig_forms, 0, 0); - } else if (SAME_OBJ(gval, scheme_define_values_syntax) - || SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { - /* Turn defines into a letrec: */ - Scheme_Object *var, *vars, *v, *link; - Scheme_Object *l = scheme_null, *start = NULL; - Scheme_Object *stx_l = scheme_null, *stx_start = NULL; - int is_val; - - while (1) { - int cnt; - - if (!SCHEME_NULLP(pre_exprs)) { - Scheme_Object *begin_stx, *values_app_stx; - - pre_exprs = scheme_reverse(pre_exprs); - - begin_stx = scheme_datum_to_syntax(begin_symbol, - scheme_false, - scheme_sys_wraps(env), - 0, 0); - values_app_stx = scheme_datum_to_syntax(scheme_make_pair(values_symbol, scheme_null), - scheme_false, - scheme_sys_wraps(env), - 0, 0); - - while (SCHEME_PAIRP(pre_exprs)) { - v = scheme_make_pair(scheme_null, - scheme_make_pair(scheme_make_pair(begin_stx, - scheme_make_pair(SCHEME_CAR(pre_exprs), - scheme_make_pair(values_app_stx, - scheme_null))), - scheme_null)); - v = scheme_datum_to_syntax(v, SCHEME_CAR(pre_exprs), SCHEME_CAR(pre_exprs), 0, 0); - - link = scheme_make_pair(v, scheme_null); - if (!start) - start = link; - else - SCHEME_CDR(l) = link; - l = link; - - pre_exprs = SCHEME_CDR(pre_exprs); - } - } - - is_val = SAME_OBJ(gval, scheme_define_values_syntax); - - v = SCHEME_STX_CDR(first); - - if (is_val) { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(rec[drec].observer); - } else { - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(rec[drec].observer); - } - - if (!SCHEME_STX_PAIRP(v)) - scheme_wrong_syntax(NULL, NULL, first, - "bad syntax (" IMPROPER_LIST_FORM ")"); - - var = NULL; - vars = SCHEME_STX_CAR(v); - cnt = 0; - while (SCHEME_STX_PAIRP(vars)) { - var = SCHEME_STX_CAR(vars); - if (!SCHEME_STX_SYMBOLP(var)) - scheme_wrong_syntax(NULL, var, first, - "name must be an identifier"); - /* scheme_dup_symbol_check(&r, "internal definition", var, "binding", first); */ - vars = SCHEME_STX_CDR(vars); - cnt++; - } - if (!SCHEME_STX_NULLP(vars)) { - vars = SCHEME_STX_CAR(v); - scheme_wrong_syntax(NULL, vars, first, - "not a sequence of identifiers"); - } - - /* Preserve properties and track at the clause level: */ - v = scheme_datum_to_syntax(v, first, first, 0, 0); - var = SCHEME_STX_CAR(first); - v = scheme_stx_track(v, first, var); - - SCHEME_EXPAND_OBSERVE_RENAME_ONE(rec[drec].observer,v); - - link = scheme_make_pair(v, scheme_null); - if (is_val) { - if (!start) - start = link; - else - SCHEME_CDR(l) = link; - l = link; - } else { - if (!stx_start) - stx_start = link; - else - SCHEME_CDR(stx_l) = link; - stx_l = link; - } - - result = SCHEME_STX_CDR(result); - if (!SCHEME_STX_NULLP(result) && !SCHEME_STX_PAIRP(result)) - scheme_wrong_syntax(NULL, NULL, first, NULL); - - { - /* Execute internal macro definition and register non-macros */ - Scheme_Comp_Env *new_env; - Scheme_Object *names, *expr, *l, *a; - int pos; - - new_env = scheme_new_compilation_frame(0, SCHEME_FOR_INTDEF, env, rec[drec].certs); - - names = SCHEME_STX_CAR(v); - expr = SCHEME_STX_CDR(v); - if (!SCHEME_STX_PAIRP(expr)) { - if (SCHEME_STX_NULLP(expr)) - scheme_wrong_syntax(NULL, NULL, first, - "bad syntax (missing expression)"); - else - scheme_wrong_syntax(NULL, NULL, first, - "bad syntax (" IMPROPER_LIST_FORM ")"); - } - link = SCHEME_STX_CDR(expr); - if (!SCHEME_STX_NULLP(link)) { - scheme_wrong_syntax(NULL, NULL, first, - "bad syntax (extra data after expression)"); - } - expr = SCHEME_STX_CAR(expr); - - scheme_add_local_syntax(cnt, new_env); - - /* Initialize environment slots to #f, which means "not syntax". */ - cnt = 0; - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - scheme_set_local_syntax(cnt++, a, scheme_false, new_env); - } - - /* Extend shared rib with renamings */ - scheme_add_env_renames(rib, new_env, env); - - /* Check for duplicates after extending the rib with renamings, - since the renamings properly track marks. */ - for (l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - scheme_dup_symbol_check(&r, "internal definition", a, "binding", first); - } - - if (!is_val) { - /* Evaluate and bind syntaxes */ - scheme_prepare_exp_env(new_env->genv); - scheme_prepare_compile_env(new_env->genv->exp_env); - pos = 0; - expr = scheme_add_rename_rib(expr, rib); - scheme_bind_syntaxes("local syntax definition", - names, expr, - new_env->genv->exp_env, new_env->insp, rec, drec, - new_env, new_env, - &pos, rib); - } - - /* Remember extended environment */ - ((void **)SCHEME_PTR1_VAL(ctx))[0] = new_env; - env = new_env; - xenv = NULL; - } - - define_try_again: - if (!SCHEME_STX_NULLP(result)) { - first = SCHEME_STX_CAR(result); - first = scheme_datum_to_syntax(first, forms, forms, 0, 0); - { - Scheme_Object *old_first; - old_first = first; - first = scheme_add_rename_rib(first, rib); - SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - SCHEME_EXPAND_OBSERVE_BLOCK_RENAMES(rec[drec].observer,old_first,first); - } - first = scheme_check_immediate_macro(first, env, rec, drec, 1, &gval, &xenv, ectx); - more = 1; - if (NOT_SAME_OBJ(gval, scheme_define_values_syntax) - && NOT_SAME_OBJ(gval, scheme_define_syntaxes_syntax)) { - if (SAME_OBJ(gval, scheme_begin_syntax)) { - /* Inline content */ - result = SCHEME_STX_CDR(result); - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(rec[drec].observer); - result = scheme_flatten_begin(first, result); - SCHEME_EXPAND_OBSERVE_SPLICE(rec[drec].observer,result); - goto define_try_again; - } else if (mixed) { - /* accumulate expr for either sequence after definitions - or made-up empty bindings before the next definition */ - pre_exprs = scheme_make_pair(first, pre_exprs); - result = SCHEME_STX_CDR(result); - goto define_try_again; - } else { - /* Keep partially expanded `first': */ - result = SCHEME_STX_CDR(result); - result = scheme_make_pair(first, result); - break; - } - } - } else - break; - } - - if (SCHEME_STX_PAIRP(result) || SCHEME_PAIRP(pre_exprs)) { - if (!start) - start = scheme_null; - - if (SCHEME_PAIRP(pre_exprs)) - result = scheme_reverse(pre_exprs); /* from mixed mode */ - - if (!mixed) { - result = scheme_make_pair(scheme_make_pair(scheme_intern_symbol("#%stratified-body"), - result), - scheme_null); - } - - if (stx_start) { - result = scheme_make_pair(letrec_syntaxes_symbol, - scheme_make_pair(stx_start, - scheme_make_pair(start, result))); - } else { - result = scheme_make_pair(letrec_values_symbol, scheme_make_pair(start, result)); - } - result = scheme_datum_to_syntax(result, forms, scheme_sys_wraps(env), 0, 2); - result = scheme_add_rename_rib(result, rib); - - more = 0; - } else { - /* Empty body: illegal. */ - scheme_wrong_syntax(scheme_begin_stx_string, NULL, orig, - "no expression after a sequence of internal definitions"); - } - } else if (mixed) { - /* accumulate expr for either an expr-only sequence or made-up - empty bindings before a definition that appears later */ - pre_exprs = scheme_make_pair(first, pre_exprs); - first = SCHEME_STX_CDR(forms); - forms = scheme_datum_to_syntax(first, forms, forms, 0, 0); - if (SCHEME_STX_NULLP(forms)) { - /* fall through to handle expressions without definitions */ - } else { - goto try_again; - } - } else { - /* fall through to handle just expressions in non-mixed mode */ - } - - if (!more) { - /* We've converted to a letrec or letrec-values+syntaxes */ - scheme_stx_seal_rib(rib); - rec[drec].env_already = 1; - - if (rec[drec].comp) { - result = scheme_compile_expr(result, env, rec, drec); - return scheme_make_pair(result, scheme_null); - } else { - if (rec[drec].depth > 0) - --rec[drec].depth; - if (rec[drec].depth) { - result = scheme_make_pair(result, scheme_null); - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result); - return scheme_expand_list(result, env, rec, drec); - } else { - result = scheme_make_pair(result, scheme_null); - return scheme_datum_to_syntax(result, forms, forms, 0, 0); - } - } - } - } - - scheme_stx_seal_rib(rib); - - if (SCHEME_PAIRP(pre_exprs)) - pre_exprs = scheme_reverse(pre_exprs); - - if (rec[drec].comp) { - Scheme_Object *vname, *rest; - - vname = rec[drec].value_name; - scheme_compile_rec_done_local(rec, drec); - scheme_init_compile_recs(rec, drec, recs, 2); - - if (SCHEME_NULLP(pre_exprs)) - rest = SCHEME_STX_CDR(forms); - else { - first = SCHEME_CAR(pre_exprs); - rest = SCHEME_CDR(pre_exprs); - } - - if (SCHEME_STX_NULLP(rest)) - recs[0].value_name = vname; - else - recs[1].value_name = vname; - - rest = scheme_datum_to_syntax(rest, orig, orig, 0, 0); - - first = scheme_compile_expr(first, env, recs, 0); - - forms = scheme_compile_list(rest, env, recs, 1); - - scheme_merge_compile_recs(rec, drec, recs, 2); - return scheme_make_pair(first, forms); - } else { - Scheme_Object *newforms, *vname; - - vname = rec[drec].value_name; - rec[drec].value_name = scheme_false; - scheme_init_expand_recs(rec, drec, recs, 2); - - recs[0].value_name = vname; - - if (SCHEME_PAIRP(pre_exprs)) - newforms = pre_exprs; - else { - newforms = SCHEME_STX_CDR(forms); - newforms = scheme_make_pair(first, newforms); - } - - forms = scheme_datum_to_syntax(newforms, orig, orig, 0, -1); - - if (scheme_stx_proper_list_length(forms) < 0) - scheme_wrong_syntax(scheme_begin_stx_string, NULL, forms, "bad syntax"); - - SCHEME_EXPAND_OBSERVE_BLOCK_TO_LIST(rec[drec].observer, forms); - forms = scheme_expand_list(forms, env, recs, 0); - return forms; - } -} - -Scheme_Object * -scheme_compile_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return scheme_compile_expand_block(forms, env, rec, drec, 1); -} - -Scheme_Object * -scheme_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return scheme_compile_expand_block(forms, env, erec, drec, 1); -} - -Scheme_Object * -scheme_compile_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return scheme_compile_expand_block(forms, env, rec, drec, 0); -} - -Scheme_Object * -scheme_expand_stratified_block(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return scheme_compile_expand_block(forms, env, erec, drec, 0); -} - -Scheme_Object * -scheme_expand_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *first = NULL, *last = NULL, *fm; - - SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form); - - if (SCHEME_STX_NULLP(form)) { - SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form); - return scheme_null; - } - - if (scheme_stx_proper_list_length(form) < 0) { - /* This is already checked for anything but application */ - scheme_wrong_syntax(scheme_application_stx_string, NULL, form, - "bad syntax (" IMPROPER_LIST_FORM ")"); - } - - fm = form; - while (SCHEME_STX_PAIRP(fm)) { - Scheme_Object *r, *p; - Scheme_Expand_Info erec1; - - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - - p = SCHEME_STX_CDR(fm); - - scheme_init_expand_recs(erec, drec, &erec1, 1); - erec1.value_name = (SCHEME_STX_NULLP(p) ? erec[drec].value_name : scheme_false); - - r = SCHEME_STX_CAR(fm); - r = scheme_expand_expr(r, env, &erec1, 0); - p = scheme_make_pair(r, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - - fm = SCHEME_STX_CDR(fm); - } - - form = scheme_datum_to_syntax(first, form, form, 0, 0); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form); - return form; -} - - -Scheme_Object * -scheme_flatten_begin(Scheme_Object *expr, Scheme_Object *append_onto) -{ - Scheme_Object *l, *ll, *a, *name, *body; - - if (scheme_stx_proper_list_length(expr) < 0) - scheme_wrong_syntax(NULL, NULL, expr, "bad syntax (" IMPROPER_LIST_FORM ")"); - - name = SCHEME_STX_CAR(expr); - body = SCHEME_STX_CDR(expr); - - /* Extract body of `begin' and add tracking information */ - l = scheme_copy_list(scheme_flatten_syntax_list(body, NULL)); - for (ll = l; !SCHEME_NULLP(ll); ll = SCHEME_CDR(ll)) { - a = SCHEME_CAR(ll); - a = scheme_stx_track(a, expr, name); - a = scheme_stx_cert(a, NULL, NULL, expr, NULL, 1); - SCHEME_CAR(ll) = a; - } - - return scheme_append(l, append_onto); -} - /*========================================================================*/ /* continuation marks */ /*========================================================================*/ @@ -9159,6 +1531,633 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj scheme_longjmp(MZTHREADELEM(p, error_buf), 1); } +/*========================================================================*/ +/* evaluation of various forms */ +/*========================================================================*/ + +void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val, + int set_undef) +{ + if ((b->val || set_undef) + && ((b->so.type != scheme_variable_type) + || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_IMMUTATED)) + && (val || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_LINKED))) + b->val = val; + else { + Scheme_Env *home; + home = scheme_get_bucket_home(b); + if (home && home->module) { + const char *msg; + int is_set; + + if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) + msg = "%s: cannot %s: %S in module: %D"; + else + msg = "%s: cannot %s: %S"; + + is_set = !strcmp(who, "set!"); + + scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key, + msg, + who, + (b->val + ? (!val + ? "undefine variable that is used by other modules" + : (is_set + ? "modify a constant" + : "re-define a constant")) + : "set variable before its definition"), + (Scheme_Object *)b->key, + home->module->modsrc); + } else { + scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key, + "%s: cannot %s variable: %S", + who, + (val + ? (b->val ? "change constant" : "set undefined") + : "undefine"), + (Scheme_Object *)b->key); + } + } +} + +void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v) +{ + Scheme_Object *macro; + + macro = scheme_alloc_small_object(); + macro->type = scheme_macro_type; + SCHEME_PTR_VAL(macro) = v; + + b->val = macro; +} + +static Scheme_Object * +define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, + Resolve_Prefix *rp, Scheme_Env *dm_env, + Scheme_Dynamic_State *dyn_state) +{ + Scheme_Object *name, *macro, *vals_expr, *vals, *var; + int i, g, show_any; + Scheme_Bucket *b; + Scheme_Object **save_runstack = NULL; + + vals_expr = SCHEME_VEC_ELS(vec)[0]; + + if (dm_env) { + scheme_prepare_exp_env(dm_env); + + save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL); + vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); + if (defmacro == 2) + dm_env = NULL; + else + scheme_pop_prefix(save_runstack); + } else { + vals = _scheme_eval_linked_expr_multi(vals_expr); + dm_env = NULL; + } + + if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { + Scheme_Object **values; + + i = SCHEME_VEC_SIZE(vec) - delta; + + g = scheme_current_thread->ku.multiple.count; + if (i == g) { + values = scheme_current_thread->ku.multiple.array; + scheme_current_thread->ku.multiple.array = NULL; + if (SAME_OBJ(values, scheme_current_thread->values_buffer)) + scheme_current_thread->values_buffer = NULL; + for (i = 0; i < g; i++) { + var = SCHEME_VEC_ELS(vec)[i+delta]; + if (dm_env) { + b = scheme_global_keyword_bucket(var, dm_env); + + macro = scheme_alloc_small_object(); + macro->type = scheme_macro_type; + SCHEME_PTR_VAL(macro) = values[i]; + + scheme_set_global_bucket("define-syntaxes", b, macro, 1); + scheme_shadow(dm_env, (Scheme_Object *)b->key, 0); + } else { + Scheme_Prefix *toplevels; + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + + scheme_set_global_bucket("define-values", b, values[i], 1); + scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1); + + if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) { + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + } + } + } + if (defmacro) + scheme_pop_prefix(save_runstack); + + return scheme_void; + } + + if (SAME_OBJ(scheme_current_thread->ku.multiple.array, scheme_current_thread->values_buffer)) + scheme_current_thread->values_buffer = NULL; + } else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */ + var = SCHEME_VEC_ELS(vec)[delta]; + if (dm_env) { + b = scheme_global_keyword_bucket(var, dm_env); + + macro = scheme_alloc_small_object(); + macro->type = scheme_macro_type; + SCHEME_PTR_VAL(macro) = vals; + + scheme_set_global_bucket("define-syntaxes", b, macro, 1); + scheme_shadow(dm_env, (Scheme_Object *)b->key, 0); + } else { + Scheme_Prefix *toplevels; + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + + scheme_set_global_bucket("define-values", b, vals, 1); + scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1); + + if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) { + int flags = GLOB_IS_IMMUTATED; + if (SCHEME_PROCP(vals_expr) + || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type) + || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_case_lambda_sequence_type)) + flags |= GLOB_IS_CONSISTENT; + ((Scheme_Bucket_With_Flags *)b)->flags |= flags; + } + + if (defmacro) + scheme_pop_prefix(save_runstack); + } + + return scheme_void; + } else + g = 1; + + /* Special handling of 0 values for define-syntaxes: + do nothing. This makes (define-values (a b c) (values)) + a kind of declaration form, which is useful is + a, b, or c is introduced by a macro. */ + if (dm_env && !g) + return scheme_void; + + i = SCHEME_VEC_SIZE(vec) - delta; + + show_any = i; + + if (show_any) { + var = SCHEME_VEC_ELS(vec)[delta]; + if (dm_env) { + b = scheme_global_keyword_bucket(var, dm_env); + name = (Scheme_Object *)b->key; + } else { + Scheme_Prefix *toplevels; + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; + b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; + name = (Scheme_Object *)b->key; + } + } else + name = NULL; + + if (defmacro > 1) + scheme_pop_prefix(save_runstack); + + { + const char *symname; + + symname = (show_any ? scheme_symbol_name(name) : ""); + + scheme_wrong_return_arity((defmacro + ? (dm_env ? "define-syntaxes" : "define-values-for-syntax") + : "define-values"), + i, g, + (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, + "%s%s%s", + show_any ? "defining \"" : "0 names", + symname, + show_any ? ((i == 1) ? "\"" : "\", ...") : ""); + } + + return NULL; +} + +static Scheme_Object * +define_values_execute(Scheme_Object *data) +{ + return define_execute_with_dynamic_state(data, 1, 0, NULL, NULL, NULL); +} + +static Scheme_Object * +set_execute (Scheme_Object *data) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; + Scheme_Object *val; + Scheme_Bucket *var; + Scheme_Prefix *toplevels; + + val = _scheme_eval_linked_expr(sb->val); + + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(sb->var)]; + var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(sb->var)]; + + scheme_set_global_bucket("set!", var, val, sb->set_undef); + + return scheme_void; +} + +static Scheme_Object * +ref_execute (Scheme_Object *data) +{ + Scheme_Prefix *toplevels; + Scheme_Object *o; + Scheme_Bucket *var; + Scheme_Object *tl = SCHEME_PTR1_VAL(data); + Scheme_Env *env; + + toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; + var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; + env = scheme_environment_from_dummy(SCHEME_CDR(data)); + + o = scheme_alloc_object(); + o->type = scheme_global_ref_type; + SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; + SCHEME_PTR2_VAL(o) = (Scheme_Object *)env; + + return o; +} + +static Scheme_Object *apply_values_execute(Scheme_Object *data) +{ + Scheme_Object *f, *v; + + f = SCHEME_PTR1_VAL(data); + + f = _scheme_eval_linked_expr(f); + if (!SCHEME_PROCP(f)) { + Scheme_Object *a[1]; + a[0] = f; + scheme_wrong_type("call-with-values", "procedure", -1, 1, a); + return NULL; + } + + v = _scheme_eval_linked_expr_multi(SCHEME_PTR2_VAL(data)); + if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; + int num_rands = p->ku.multiple.count; + + if (num_rands > p->tail_buffer_size) { + /* scheme_tail_apply will allocate */ + if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) + p->values_buffer = NULL; + } + return scheme_tail_apply(f, num_rands, p->ku.multiple.array); + } else { + Scheme_Object *a[1]; + a[0] = v; + return scheme_tail_apply(f, 1, a); + } +} + +Scheme_Object * +scheme_case_lambda_execute(Scheme_Object *expr) +{ + Scheme_Case_Lambda *seqin, *seqout; + int i, cnt; + Scheme_Thread *p = scheme_current_thread; + + seqin = (Scheme_Case_Lambda *)expr; + +#ifdef MZ_USE_JIT + if (seqin->native_code) { + Scheme_Native_Closure_Data *ndata; + Scheme_Native_Closure *nc, *na; + Scheme_Closure_Data *data; + Scheme_Object *val; + GC_CAN_IGNORE Scheme_Object **runstack; + GC_CAN_IGNORE mzshort *map; + int j, jcnt; + + ndata = seqin->native_code; + nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata); + + cnt = seqin->count; + for (i = 0; i < cnt; i++) { + val = seqin->array[i]; + if (!SCHEME_PROCP(val)) { + data = (Scheme_Closure_Data *)val; + na = (Scheme_Native_Closure *)scheme_make_native_closure(data->u.native_code); + runstack = MZ_RUNSTACK; + jcnt = data->closure_size; + map = data->closure_map; + for (j = 0; j < jcnt; j++) { + na->vals[j] = runstack[map[j]]; + } + val = (Scheme_Object *)na; + } + nc->vals[i] = val; + } + + return (Scheme_Object *)nc; + } +#endif + + seqout = (Scheme_Case_Lambda *) + scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + + (seqin->count - 1) * sizeof(Scheme_Object *)); + seqout->so.type = scheme_case_closure_type; + seqout->count = seqin->count; + seqout->name = seqin->name; + + cnt = seqin->count; + for (i = 0; i < cnt; i++) { + if (SAME_TYPE(SCHEME_TYPE(seqin->array[i]), scheme_closure_type)) { + /* An empty closure, created at compile time */ + seqout->array[i] = seqin->array[i]; + } else { + Scheme_Object *lc; + lc = scheme_make_closure(p, seqin->array[i], 1); + seqout->array[i] = lc; + } + } + + return (Scheme_Object *)seqout; +} + +Scheme_Object *scheme_make_envunbox(Scheme_Object *value) +{ + Scheme_Object *obj; + + obj = (Scheme_Object *)scheme_malloc_envunbox(sizeof(Scheme_Object*)); + SCHEME_ENVBOX_VAL(obj) = value; + + return obj; +} + +static Scheme_Object *bangboxenv_execute(Scheme_Object *data) +/* A bangboxenv step is inserted by the compilation of `lambda' and + `let' forms where an argument or bindings is set!ed in the body. */ +{ + int pos = SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)); + Scheme_Object *bb; + + data = SCHEME_PTR2_VAL(data); + + bb = scheme_make_envunbox(MZ_RUNSTACK[pos]); + MZ_RUNSTACK[pos] = bb; + + return _scheme_tail_eval(data); +} + +static Scheme_Object * +begin0_execute(Scheme_Object *obj) +{ + Scheme_Object *v, **mv; + int i, mc, apos; + + i = ((Scheme_Sequence *)obj)->count; + + v = _scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[0]); + i--; + if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { + Scheme_Thread *p = scheme_current_thread; + mv = p->ku.multiple.array; + mc = p->ku.multiple.count; + if (SAME_OBJ(mv, p->values_buffer)) + p->values_buffer = NULL; + } else { + mv = NULL; + mc = 0; /* makes compilers happy */ + } + + apos = 1; + while (i--) { + (void)_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++]); + } + + if (mv) { + Scheme_Thread *p = scheme_current_thread; + p->ku.multiple.array = mv; + p->ku.multiple.count = mc; + } + + return v; +} + +static Scheme_Object *splice_one_expr(void *expr, int argc, Scheme_Object **argv) +{ + return _scheme_eval_linked_expr_multi((Scheme_Object *)expr); +} + +static Scheme_Object *splice_execute(Scheme_Object *data) +{ + if (SAME_TYPE(SCHEME_TYPE(data), scheme_splice_sequence_type)) { + Scheme_Sequence *seq = (Scheme_Sequence *)data; + int i, cnt = seq->count - 1; + + for (i = 0; i < cnt; i++) { + (void)_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i]); + } + + return _scheme_eval_linked_expr_multi(seq->array[cnt]); + } else { + /* sequence was optimized on read? */ + return _scheme_eval_linked_expr_multi(data); + } +} + +static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env, int for_stx); + +static void *define_syntaxes_execute_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *form = p->ku.k.p1; + Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2; + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + return do_define_syntaxes_execute(form, dm_env, p->ku.k.i1); +} + +static Scheme_Object * +do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) +{ + Scheme_Thread *p = scheme_current_thread; + Resolve_Prefix *rp; + Scheme_Object *base_stack_depth, *dummy; + int depth; + Scheme_Comp_Env *rhs_env; + + rp = (Resolve_Prefix *)SCHEME_VEC_ELS(form)[1]; + base_stack_depth = SCHEME_VEC_ELS(form)[2]; + + depth = SCHEME_INT_VAL(base_stack_depth) + rp->num_stxes + 1; + if (!scheme_check_runstack(depth)) { + p->ku.k.p1 = form; + + if (!dm_env) { + /* Need to get env before we enlarge the runstack: */ + dummy = SCHEME_VEC_ELS(form)[3]; + dm_env = scheme_environment_from_dummy(dummy); + } + p->ku.k.p2 = (Scheme_Object *)dm_env; + p->ku.k.i1 = for_stx; + + return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k); + } + + dummy = SCHEME_VEC_ELS(form)[3]; + + rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, SCHEME_TOPLEVEL_FRAME); + + if (!dm_env) + dm_env = scheme_environment_from_dummy(dummy); + + { + Scheme_Dynamic_State dyn_state; + Scheme_Cont_Frame_Data cframe; + Scheme_Config *config; + Scheme_Object *result; + + scheme_prepare_exp_env(dm_env); + + config = scheme_extend_config(scheme_current_config(), + MZCONFIG_ENV, + (Scheme_Object *)dm_env->exp_env); + scheme_push_continuation_frame(&cframe); + scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); + + scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, NULL, dm_env, dm_env->link_midx); + result = define_execute_with_dynamic_state(form, 4, for_stx ? 2 : 1, rp, dm_env, &dyn_state); + + scheme_pop_continuation_frame(&cframe); + + return result; + } +} + +static Scheme_Object * +define_syntaxes_execute(Scheme_Object *form) +{ + return do_define_syntaxes_execute(form, NULL, 0); +} + +static Scheme_Object * +define_for_syntaxes_execute(Scheme_Object *form) +{ + return do_define_syntaxes_execute(form, NULL, 1); +} + +/*========================================================================*/ +/* closures */ +/*========================================================================*/ + +Scheme_Object * +scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close) + /* Creates a closure at run-time (or an empty closure at compile + time; note that the byte-code marshaller in print.c can handle + empty closures for that reason). */ +{ + Scheme_Closure_Data *data; + Scheme_Closure *closure; + GC_CAN_IGNORE Scheme_Object **runstack; + GC_CAN_IGNORE Scheme_Object **dest; + GC_CAN_IGNORE mzshort *map; + int i; + + data = (Scheme_Closure_Data *)code; + +#ifdef MZ_USE_JIT + if (data->u.native_code) { + Scheme_Object *nc; + + nc = scheme_make_native_closure(data->u.native_code); + + if (close) { + runstack = MZ_RUNSTACK; + dest = ((Scheme_Native_Closure *)nc)->vals; + map = data->closure_map; + i = data->closure_size; + + /* Copy data into the closure: */ + while (i--) { + dest[i] = runstack[map[i]]; + } + } + + return nc; + } +#endif + + i = data->closure_size; + + closure = (Scheme_Closure *) + scheme_malloc_tagged(sizeof(Scheme_Closure) + + (i - 1) * sizeof(Scheme_Object *)); + + closure->so.type = scheme_closure_type; + SCHEME_COMPILED_CLOS_CODE(closure) = data; + + if (!close || !i) + return (Scheme_Object *)closure; + + runstack = MZ_RUNSTACK; + dest = closure->vals; + map = data->closure_map; + + /* Copy data into the closure: */ + while (i--) { + dest[i] = runstack[map[i]]; + } + + return (Scheme_Object *)closure; +} + +Scheme_Closure *scheme_malloc_empty_closure() +{ + Scheme_Closure *cl; + + cl = (Scheme_Closure *)scheme_malloc_tagged(sizeof(Scheme_Closure) - sizeof(Scheme_Object *)); + cl->so.type = scheme_closure_type; + + return cl; +} + +void scheme_delay_load_closure(Scheme_Closure_Data *data) +{ + if (SCHEME_RPAIRP(data->code)) { + Scheme_Object *v, *vinfo = NULL; + + v = SCHEME_CAR(data->code); + if (SCHEME_VECTORP(v)) { + /* Has info for delayed validation */ + vinfo = v; + v = SCHEME_VEC_ELS(vinfo)[0]; + } + v = scheme_load_delayed_code(SCHEME_INT_VAL(v), + (struct Scheme_Load_Delay *)SCHEME_CDR(data->code)); + data->code = v; + + if (vinfo) { + scheme_validate_closure(NULL, + (Scheme_Object *)data, + (char *)SCHEME_VEC_ELS(vinfo)[1], + (Validate_TLS)SCHEME_VEC_ELS(vinfo)[2], + SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[3]), + SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[4]), + SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[5]), + (SCHEME_TRUEP(SCHEME_VEC_ELS(vinfo)[8]) + ? (void *)SCHEME_VEC_ELS(vinfo)[8] + : NULL), + SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[6]), + (SCHEME_TRUEP(SCHEME_VEC_ELS(vinfo)[7]) + ? (Scheme_Hash_Tree *)SCHEME_VEC_ELS(vinfo)[7] + : NULL)); + } + } +} + /*========================================================================*/ /* main eval-apply loop */ /*========================================================================*/ @@ -10370,43 +3369,43 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, case scheme_define_values_type: { UPDATE_THREAD_RSPTR(); - v = scheme_define_values_execute(obj); + v = define_values_execute(obj); break; } case scheme_define_syntaxes_type: { UPDATE_THREAD_RSPTR(); - v = scheme_define_syntaxes_execute(obj); + v = define_syntaxes_execute(obj); break; } case scheme_define_for_syntax_type: { UPDATE_THREAD_RSPTR(); - v = scheme_define_for_syntaxes_execute(obj); + v = define_for_syntaxes_execute(obj); break; } case scheme_set_bang_type: { UPDATE_THREAD_RSPTR(); - v = scheme_set_execute(obj); + v = set_execute(obj); break; } case scheme_boxenv_type: { UPDATE_THREAD_RSPTR(); - v = scheme_bangboxenv_execute(obj); + v = bangboxenv_execute(obj); break; } case scheme_begin0_sequence_type: { UPDATE_THREAD_RSPTR(); - v = scheme_begin0_execute(obj); + v = begin0_execute(obj); break; } case scheme_splice_sequence_type: { UPDATE_THREAD_RSPTR(); - v = scheme_splice_execute(obj); + v = splice_execute(obj); break; } case scheme_require_form_type: @@ -10418,13 +3417,13 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, case scheme_varref_form_type: { UPDATE_THREAD_RSPTR(); - v = scheme_ref_execute(obj); + v = ref_execute(obj); break; } case scheme_apply_values_type: { UPDATE_THREAD_RSPTR(); - v = scheme_apply_values_execute(obj); + v = apply_values_execute(obj); break; } case scheme_case_lambda_sequence_type: @@ -10497,6 +3496,303 @@ Scheme_Object **scheme_current_argument_stack() /* eval/compile/expand starting points */ /*========================================================================*/ +static Scheme_Object *add_renames_unless_module(Scheme_Object *form, Scheme_Env *genv) +{ + if (genv->rename_set) { + if (SCHEME_STX_PAIRP(form)) { + Scheme_Object *a, *d, *module_stx; + + a = SCHEME_STX_CAR(form); + if (SCHEME_STX_SYMBOLP(a)) { + a = scheme_add_rename(a, genv->rename_set); + module_stx = scheme_datum_to_syntax(scheme_intern_symbol("module"), + scheme_false, + scheme_sys_wraps_phase(scheme_make_integer(genv->phase)), + 0, 0); + if (scheme_stx_module_eq(a, module_stx, genv->phase)) { + /* Don't add renames to the whole module; let the + module's language take over. */ + d = SCHEME_STX_CDR(form); + a = scheme_make_pair(a, d); + form = scheme_datum_to_syntax(a, form, form, 0, 1); + return form; + } + } + } + } + + if (genv->rename_set) { + form = scheme_add_rename(form, genv->rename_set); + /* this "phase shift" just attaches the namespace's module registry: */ + form = scheme_stx_phase_shift(form, 0, NULL, NULL, genv->module_registry->exports); + } + + return form; +} + +static Scheme_Object *call_compile_handler(Scheme_Object *form, int immediate_eval) +{ + Scheme_Object *argv[2], *o; + + argv[0] = form; + argv[1] = (immediate_eval ? scheme_true : scheme_false); + o = scheme_get_param(scheme_current_config(), MZCONFIG_COMPILE_HANDLER); + o = scheme_apply(o, 2, argv); + + if (!SAME_TYPE(SCHEME_TYPE(o), scheme_compilation_top_type)) { + argv[0] = o; + scheme_wrong_type("compile-handler", "compiled code", 0, -1, argv); + return NULL; + } + + return o; +} + +static int get_comp_flags(Scheme_Config *config) +{ + int comp_flags = 0; + + if (!config) + config = scheme_current_config(); + + if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), + MZCONFIG_ALLOW_SET_UNDEFINED))) + comp_flags |= COMP_ALLOW_SET_UNDEFINED; + if (SCHEME_FALSEP(scheme_get_param(scheme_current_config(), + MZCONFIG_DISALLOW_INLINE))) + comp_flags |= COMP_CAN_INLINE; + + return comp_flags; +} + +static void *compile_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *form; + int writeable, for_eval, rename, enforce_consts, comp_flags; + Scheme_Env *genv; + Scheme_Compile_Info rec, rec2; + Scheme_Object *o, *rl, *tl_queue; + Scheme_Compilation_Top *top; + Resolve_Prefix *rp; + Resolve_Info *ri; + Optimize_Info *oi; + Scheme_Object *gval, *insp; + Scheme_Comp_Env *cenv; + + form = (Scheme_Object *)p->ku.k.p1; + genv = (Scheme_Env *)p->ku.k.p2; + writeable = p->ku.k.i1; + for_eval = p->ku.k.i2; + rename = p->ku.k.i3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + if (!SCHEME_STXP(form)) { + form = scheme_datum_to_syntax(form, scheme_false, scheme_false, 1, 0); + rename = 1; + } + + /* Renamings for requires: */ + if (rename) { + form = add_renames_unless_module(form, genv); + if (genv->module) { + form = scheme_stx_phase_shift(form, 0, + genv->module->me->src_modidx, + genv->module->self_modidx, + genv->module_registry->exports); + } + } + + tl_queue = scheme_null; + + { + Scheme_Config *config; + config = scheme_current_config(); + insp = scheme_get_param(config, MZCONFIG_CODE_INSPECTOR); + enforce_consts = SCHEME_TRUEP(scheme_get_param(config, MZCONFIG_COMPILE_MODULE_CONSTS)); + comp_flags = get_comp_flags(config); + } + + while (1) { + scheme_prepare_compile_env(genv); + + rec.comp = 1; + rec.dont_mark_local_use = 0; + rec.resolve_module_ids = !writeable && !genv->module; + rec.no_module_cert = 0; + rec.value_name = scheme_false; + rec.certs = NULL; + rec.observer = NULL; + rec.pre_unwrapped = 0; + rec.env_already = 0; + rec.comp_flags = comp_flags; + + cenv = scheme_new_comp_env(genv, insp, SCHEME_TOPLEVEL_FRAME); + + if (for_eval) { + /* Need to look for top-level `begin', and if we + find one, break it up to eval first expression + before the rest. */ + while (1) { + scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), + scheme_false, scheme_false, scheme_null, scheme_false); + form = scheme_check_immediate_macro(form, + cenv, &rec, 0, + 0, &gval, NULL, NULL); + if (SAME_OBJ(gval, scheme_begin_syntax)) { + if (scheme_stx_proper_list_length(form) > 1){ + form = SCHEME_STX_CDR(form); + tl_queue = scheme_append(scheme_flatten_syntax_list(form, NULL), + tl_queue); + tl_queue = scheme_append(scheme_frame_get_lifts(cenv), + tl_queue); + form = SCHEME_CAR(tl_queue); + tl_queue = SCHEME_CDR(tl_queue); + } else + break; + } else { + rl = scheme_frame_get_require_lifts(cenv); + o = scheme_frame_get_lifts(cenv); + if (!SCHEME_NULLP(o) + || !SCHEME_NULLP(rl)) { + tl_queue = scheme_make_pair(form, tl_queue); + tl_queue = scheme_append(o, tl_queue); + tl_queue = scheme_append(rl, tl_queue); + form = SCHEME_CAR(tl_queue); + tl_queue = SCHEME_CDR(tl_queue); + } + break; + } + } + } + + if (for_eval) { + o = call_compile_handler(form, 1); + top = (Scheme_Compilation_Top *)o; + } else { + /* We want to simply compile `form', but we have to loop in case + an expression is lifted in the process of compiling: */ + Scheme_Object *l, *prev_o = NULL; + int max_let_depth; + + while (1) { + scheme_frame_captures_lifts(cenv, scheme_make_lifted_defn, scheme_sys_wraps(cenv), + scheme_false, scheme_false, scheme_null, scheme_false); + + scheme_init_compile_recs(&rec, 0, &rec2, 1); + + o = scheme_compile_expr(form, cenv, &rec2, 0); + + /* If we had compiled an expression in a previous iteration, + combine it in a sequence: */ + if (prev_o) { + Scheme_Sequence *seq; + seq = scheme_malloc_sequence(2); + seq->so.type = scheme_sequence_type; + seq->count = 2; + seq->array[0] = o; + seq->array[1] = prev_o; + o = (Scheme_Object *)seq; + } + + /* If any definitions were lifted in the process of compiling o, + we need to fold them in. */ + l = scheme_frame_get_lifts(cenv); + rl = scheme_frame_get_require_lifts(cenv); + if (!SCHEME_NULLP(l) + || !SCHEME_NULLP(rl)) { + rl = scheme_append(rl, l); + rl = icons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(cenv), 0, 0), + rl); + form = scheme_datum_to_syntax(rl, scheme_false, scheme_false, 0, 0); + prev_o = o; + } else + break; + } + + oi = scheme_optimize_info_create(); + scheme_optimize_info_enforce_const(oi, enforce_consts); + if (!(comp_flags & COMP_CAN_INLINE)) + scheme_optimize_info_never_inline(oi); + o = scheme_optimize_expr(o, oi, 0); + + rp = scheme_resolve_prefix(0, cenv->prefix, 1); + ri = scheme_resolve_info_create(rp); + scheme_resolve_info_enforce_const(ri, enforce_consts); + scheme_enable_expression_resolve_lifts(ri); + + o = scheme_resolve_expr(o, ri); + max_let_depth = scheme_resolve_info_max_let_depth(ri); + o = scheme_sfs(o, NULL, max_let_depth); + + o = scheme_merge_expression_resolve_lifts(o, rp, ri); + + rp = scheme_remap_prefix(rp, ri); + + top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); + top->so.type = scheme_compilation_top_type; + top->max_let_depth = max_let_depth; + top->code = o; + top->prefix = rp; + + if (0) { /* <- change to 1 to check compilation result */ + scheme_validate_code(NULL, top->code, + top->max_let_depth, + top->prefix->num_toplevels, + top->prefix->num_stxes, + top->prefix->num_lifts, + NULL, + 0); + } + } + + if (SCHEME_PAIRP(tl_queue)) { + /* This compile is interleaved with evaluation, + and we need to eval now before compiling more. */ + _eval_compiled_multi_with_prompt((Scheme_Object *)top, genv); + + form = SCHEME_CAR(tl_queue); + tl_queue = SCHEME_CDR(tl_queue); + } else + break; + } + + return (void *)top; +} + +static Scheme_Object *_compile(Scheme_Object *form, Scheme_Env *env, int writeable, int for_eval, int eb, int rename) +{ + Scheme_Thread *p = scheme_current_thread; + + if (SAME_TYPE(SCHEME_TYPE(form), scheme_compilation_top_type)) + return form; + + if (SCHEME_STXP(form)) { + if (SAME_TYPE(SCHEME_TYPE(SCHEME_STX_VAL(form)), scheme_compilation_top_type)) + return SCHEME_STX_VAL(form); + } + + p->ku.k.p1 = form; + p->ku.k.p2 = env; + p->ku.k.i1 = writeable; + p->ku.k.i2 = for_eval; + p->ku.k.i3 = rename; + + return (Scheme_Object *)scheme_top_level_do(compile_k, eb); +} + +Scheme_Object *scheme_compile(Scheme_Object *form, Scheme_Env *env, int writeable) +{ + return _compile(form, env, writeable, 0, 1, 1); +} + +Scheme_Object *scheme_compile_for_eval(Scheme_Object *form, Scheme_Env *env) +{ + return _compile(form, env, 0, 1, 1, 1); +} + Scheme_Object *scheme_eval(Scheme_Object *obj, Scheme_Env *env) { return scheme_eval_compiled(scheme_compile_for_eval(obj, env), env); @@ -10818,7 +4114,8 @@ static void *expand_k(void) Scheme_Object *data; data = (as_local < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env); scheme_frame_captures_lifts(env, - (as_local < 0) ? pair_lifted : scheme_make_lifted_defn, data, + (as_local < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, + data, scheme_false, catch_lifts_key, (!as_local && catch_lifts_key) ? scheme_null : NULL, scheme_false); @@ -10838,7 +4135,7 @@ static void *expand_k(void) || SCHEME_PAIRP(rl)) { l = scheme_append(rl, l); if (as_local < 0) - obj = add_lifts_as_let(obj, l, env, scheme_false, 0); + obj = scheme_add_lifts_as_let(obj, l, env, scheme_false, 0); else obj = add_lifts_as_begin(obj, l, env); SCHEME_EXPAND_OBSERVE_LIFT_LOOP(erec1.observer,obj); @@ -11078,24 +4375,6 @@ static Scheme_Object *expand_stx(int argc, Scheme_Object **argv) -1, -1, 0, scheme_false, 0, NULL, 0); } -static Scheme_Object *stop_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - scheme_signal_error("internal error: shouldn't get to stop syntax"); - return NULL; -} - -static Scheme_Object *stop_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_STOP(erec[drec].observer); - return form; -} - -Scheme_Object *scheme_get_stop_expander(void) -{ - return stop_expander; -} - Scheme_Object *scheme_generate_lifts_key(void) { char buf[20]; @@ -11169,13 +4448,6 @@ static void update_intdef_chain(Scheme_Object *intdef) } } -static void add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env) -{ - Scheme_Object *stx; - stx = scheme_datum_to_syntax(sym, scheme_false, scheme_sys_wraps(env), 0, 0); - scheme_set_local_syntax(pos, stx, stop_expander, env); -} - static Scheme_Object * do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, int argc, Scheme_Object **argv) { @@ -11313,7 +4585,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in } if (cnt > 0) - scheme_set_local_syntax(pos++, i, stop_expander, env); + scheme_set_local_syntax(pos++, i, scheme_get_stop_expander(), env); } if (!SCHEME_NULLP(l)) { scheme_wrong_type(name, "#f or list of identifier syntax", 2, argc, argv); @@ -11321,21 +4593,21 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in } if (cnt > 0) { - add_core_stop_form(pos++, begin_symbol, env); - add_core_stop_form(pos++, scheme_intern_symbol("set!"), env); - add_core_stop_form(pos++, app_symbol, env); - add_core_stop_form(pos++, top_symbol, env); - add_core_stop_form(pos++, lambda_symbol, env); - add_core_stop_form(pos++, scheme_intern_symbol("case-lambda"), env); - add_core_stop_form(pos++, let_values_symbol, env); - add_core_stop_form(pos++, letrec_values_symbol, env); - add_core_stop_form(pos++, scheme_intern_symbol("if"), env); - add_core_stop_form(pos++, scheme_intern_symbol("begin0"), env); - add_core_stop_form(pos++, scheme_intern_symbol("with-continuation-mark"), env); - add_core_stop_form(pos++, letrec_syntaxes_symbol, env); - add_core_stop_form(pos++, scheme_intern_symbol("#%variable-reference"), env); - add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env); - add_core_stop_form(pos++, quote_symbol, env); + scheme_add_core_stop_form(pos++, begin_symbol, env); + scheme_add_core_stop_form(pos++, scheme_intern_symbol("set!"), env); + scheme_add_core_stop_form(pos++, app_symbol, env); + scheme_add_core_stop_form(pos++, top_symbol, env); + scheme_add_core_stop_form(pos++, lambda_symbol, env); + scheme_add_core_stop_form(pos++, scheme_intern_symbol("case-lambda"), env); + scheme_add_core_stop_form(pos++, let_values_symbol, env); + scheme_add_core_stop_form(pos++, letrec_values_symbol, env); + scheme_add_core_stop_form(pos++, scheme_intern_symbol("if"), env); + scheme_add_core_stop_form(pos++, scheme_intern_symbol("begin0"), env); + scheme_add_core_stop_form(pos++, scheme_intern_symbol("with-continuation-mark"), env); + scheme_add_core_stop_form(pos++, letrec_syntaxes_symbol, env); + scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%variable-reference"), env); + scheme_add_core_stop_form(pos++, scheme_intern_symbol("#%expression"), env); + scheme_add_core_stop_form(pos++, quote_symbol, env); } } @@ -11387,7 +4659,8 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in Scheme_Object *data; data = (catch_lifts < 0) ? (Scheme_Object *)ip : scheme_sys_wraps(env); scheme_frame_captures_lifts(env, - (catch_lifts < 0) ? pair_lifted : scheme_make_lifted_defn, data, + (catch_lifts < 0) ? scheme_pair_lifted : scheme_make_lifted_defn, + data, scheme_false, catch_lifts_key, NULL, scheme_false); @@ -11414,7 +4687,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in if (catch_lifts_key) { if (catch_lifts < 0) - xl = add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l, 0); + xl = scheme_add_lifts_as_let(xl, scheme_frame_get_lifts(env), env, orig_l, 0); else xl = add_lifts_as_begin(xl, scheme_frame_get_lifts(env), env); SCHEME_EXPAND_OBSERVE_LIFT_LOOP(observer,xl); @@ -12061,1276 +5334,6 @@ static void mark_pruned_prefixes(struct NewGC *gc) XFORM_SKIP_PROC } #endif -/*========================================================================*/ -/* bytecode validation */ -/*========================================================================*/ - -/* Bytecode validation is an abstract interpretation on the stack, - where the abstract values are "not available", "value", "boxed - value", "syntax object", or "global array". */ - -/* FIXME: validation doesn't check CLOS_SINGLE_RESULT or - CLOS_PRESERVES_MARKS. (Maybe check them in the JIT pass?) */ - -#define VALID_NOT 0 -#define VALID_UNINIT 1 -#define VALID_VAL 2 -#define VALID_BOX 3 -#define VALID_TOPLEVELS 4 -#define VALID_VAL_NOCLEAR 5 -#define VALID_BOX_NOCLEAR 6 -#define VALID_FLONUM 7 - -typedef struct Validate_Clearing { - MZTAG_IF_REQUIRED - int stackpos, stacksize; - int *stack; - int ncstackpos, ncstacksize; - int *ncstack; - int self_pos, self_count, self_start; -} Validate_Clearing; - -static struct Validate_Clearing *make_clearing_stack() -{ - Validate_Clearing *vc; - vc = MALLOC_ONE_RT(Validate_Clearing); - SET_REQUIRED_TAG(vc->type = scheme_rt_validate_clearing); - vc->self_pos = -1; - return vc; -} - -static void reset_clearing(struct Validate_Clearing *vc) -{ - vc->stackpos = 0; - vc->ncstackpos = 0; -} - -static void clearing_stack_push(struct Validate_Clearing *vc, int pos, int val) -{ - if (vc->stackpos + 2 > vc->stacksize) { - int *a, sz; - sz = (vc->stacksize ? 2 * vc->stacksize : 32); - a = (int *)scheme_malloc_atomic(sizeof(int) * sz); - memcpy(a, vc->stack, vc->stacksize * sizeof(int)); - vc->stacksize = sz; - vc->stack = a; - } - vc->stack[vc->stackpos] = pos; - vc->stack[vc->stackpos + 1] = val; - vc->stackpos += 2; -} - -static void noclear_stack_push(struct Validate_Clearing *vc, int pos) -{ - if (vc->ncstackpos + 1 > vc->ncstacksize) { - int *a, sz; - sz = (vc->ncstacksize ? 2 * vc->ncstacksize : 32); - a = (int *)scheme_malloc_atomic(sizeof(int) * sz); - memcpy(a, vc->ncstack, vc->ncstacksize * sizeof(int)); - vc->ncstacksize = sz; - vc->ncstack = a; - } - vc->ncstack[vc->ncstackpos] = pos; - vc->ncstackpos += 1; -} - -void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, - int depth, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - int code_vec) -{ - char *stack; - int delta; - struct Validate_Clearing *vc; - Validate_TLS tls; - - depth += ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); - - stack = scheme_malloc_atomic(depth); - memset(stack, VALID_NOT, depth); - - if (num_toplevels || num_stxes || num_lifts) { - stack[depth - 1] = VALID_TOPLEVELS; - } - - delta = depth - ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); - - tls = MALLOC_N(mzshort*, num_lifts); - - vc = make_clearing_stack(); - - if (code_vec) { - int i, cnt; - cnt = SCHEME_VEC_SIZE(code); - for (i = 0; i < cnt; i++) { - reset_clearing(vc); - scheme_validate_expr(port, SCHEME_VEC_ELS(code)[i], - stack, tls, - depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, - vc, 1, 0, NULL); - } - } else { - scheme_validate_expr(port, code, - stack, tls, - depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, - vc, 1, 0, NULL); - } -} - -static Scheme_Object *validate_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Mz_CPort *port = (Mz_CPort *)p->ku.k.p1; - Scheme_Object *expr = (Scheme_Object *)p->ku.k.p2; - char *stack = (char *)p->ku.k.p3; - int *args = (int *)(((void **)p->ku.k.p5)[0]); - Scheme_Object *app_rator = (Scheme_Object *)(((void **)p->ku.k.p5)[1]); - Validate_TLS tls = (Validate_TLS)(((void **)p->ku.k.p5)[2]); - Scheme_Hash_Tree *procs = (Scheme_Hash_Tree *)(((void **)p->ku.k.p5)[3]); - struct Validate_Clearing *vc = (struct Validate_Clearing *)p->ku.k.p4; - void *tl_use_map = (((void **)p->ku.k.p5)[4]); - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - - scheme_validate_expr(port, expr, stack, tls, - args[0], args[1], args[2], - args[3], args[4], args[5], tl_use_map, - app_rator, args[6], args[7], vc, args[8], - args[9], procs); - - return scheme_true; -} - -/* FIXME: need to validate that a flonum is provided when a - procedure expects a flonum */ - -int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos, - int hope, - Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map) -{ - Scheme_Closure_Data *data = NULL; - Scheme_Type ty; - - while (1) { - ty = SCHEME_TYPE(app_rator); - if (SAME_TYPE(ty, scheme_closure_type)) { - data = SCHEME_COMPILED_CLOS_CODE(app_rator); - break; - } else if (SAME_TYPE(ty, scheme_unclosed_procedure_type)) { - data = (Scheme_Closure_Data *)app_rator; - break; - } else if (SAME_TYPE(ty, scheme_toplevel_type)) { - int p; - p = SCHEME_TOPLEVEL_POS(app_rator); - while (1) { - if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { - /* It's a lift. Check that the lift is defined, and that it - doesn't want reference arguments. */ - mzshort *a; /* 0x1 => no ref args, - ptr with pos length => expected (0 => don't care, 1 => want not, 2 => want is), - ptr with neg length => actual - ptr with 0 => another top-level */ - int tp; - - tp = (p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0))); - if (tp >= num_lifts) - return 0; - - a = tls[tp]; - if (a == (mzshort *)0x1) { - return 0; - } else if (!a || (a[0] > 0)) { - /* The lift isn't ready. - Record what we expect to find when it is ready. */ - if (!a || (a[0] < (pos + 1))) { - mzshort *naya; - int sz; - if (a) - sz = a[0]; - else - sz = 3; - sz *= 2; - if (sz <= pos) - sz = pos + 1; - naya = scheme_malloc_atomic((sz + 1) * sizeof(mzshort)); - memset(naya, 0, (sz + 1) * sizeof(mzshort)); - if (a) - memcpy(naya, a, (a[0] + 1) * sizeof(mzshort)); - naya[0] = sz; - a = naya; - tls[tp] = a; - } - - if (!a[pos + 1]) { - a[pos + 1] = hope ? 2 : 1; - return hope; - } else if (a[pos + 1] == 2) - return 1; - else - return 0; - } else if (!a[0]) { - /* try again */ - p = a[1]; - } else { - return a[pos + 1]; - } - } else - return 0; - } - } else - return 0; - } - - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - if (pos < data->num_params) { - int bit = ((mzshort)1 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); - if (data->closure_map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) - return 1; - } - } - - return 0; -} - -static int argument_to_arity_error(Scheme_Object *app_rator, int proc_with_refs_ok) -{ - /* Since `raise-arity-error' doesn't actually apply its argument, - it's ok to pass any procedure. In particular, the compiler generates - calls to converted procedures. */ - return ((proc_with_refs_ok == 2) - && SAME_OBJ(app_rator, scheme_raise_arity_error_proc)); -} - -void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, - char *closure_stack, Validate_TLS tls, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - int self_pos_in_closure, Scheme_Hash_Tree *procs) -{ - Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; - int i, sz, cnt, base, base2; - char *new_stack; - struct Validate_Clearing *vc; - - if (data->max_let_depth < (data->num_params + data->closure_size)) - scheme_ill_formed_code(port); - - sz = data->max_let_depth; - new_stack = scheme_malloc_atomic(sz); - memset(new_stack, VALID_NOT, sz - data->num_params - data->closure_size); - - cnt = data->num_params; - base = sz - cnt; - - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - base2 = data->closure_size; - for (i = 0; i < cnt; i++) { - new_stack[base + i] = closure_stack[base2 + i]; - } - } else { - for (i = 0; i < cnt; i++) { - new_stack[i + base] = VALID_VAL; - } - } - - cnt = data->closure_size; - base = base - cnt; - for (i = 0; i < cnt; i++) { - new_stack[i + base] = closure_stack[i]; - } - - vc = make_clearing_stack(); - if (self_pos_in_closure >= 0) { - vc->self_pos = base + self_pos_in_closure; - vc->self_count = data->closure_size; - vc->self_start = base; - } - - if (data->tl_map) { - if (tl_use_map) { - /* check that data->tl_use_map => tl_use_map */ - int *a, a_buf[2], len; - - if ((uintptr_t)tl_use_map & 0x1) { - len = 1; - a_buf[1] = (((uintptr_t)data->tl_map) >> 1) & 0x7FFFFFFF; - a = a_buf; - } else { - len = ((int *)tl_use_map)[0]; - a = (int *)tl_use_map; - } - - if (tl_use_map) { - if ((uintptr_t)data->tl_map & 0x1) { - int map = (((uintptr_t)data->tl_map) >> 1) & 0x7FFFFFFF; - if ((len < 1) || ((a[1] & map) != map)) - scheme_ill_formed_code(port); - } else { - int *b = ((int *)data->tl_map); - for (i = b[0]; i--; ) { - if ((len <= i) || ((a[i+1] & b[i+1]) != b[i+1])) - scheme_ill_formed_code(port); - } - } - } - } - tl_use_map = data->tl_map; - } - - scheme_validate_expr(port, data->code, new_stack, tls, sz, sz, base, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 1, 0, procs); -} - -static Scheme_Hash_Tree *as_nonempty_procs(Scheme_Hash_Tree *procs) -{ - if (!procs) - procs = scheme_make_hash_tree(0); - return procs; -} - -static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr, - char *stack, Validate_TLS tls, - int depth, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - Scheme_Object *app_rator, int proc_with_refs_ok, - int self_pos, Scheme_Hash_Tree *procs) -{ - Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; - int i, cnt, q, p, sz, base, stack_delta, vld, self_pos_in_closure = -1, typed_arg = 0; - mzshort *map; - char *closure_stack; - Scheme_Object *proc; - Scheme_Hash_Tree *new_procs = NULL; - - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - sz = data->closure_size + data->num_params; - } else { - sz = data->closure_size; - } - map = data->closure_map; - - if (sz) - closure_stack = scheme_malloc_atomic(sz); - else - closure_stack = NULL; - - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - cnt = data->num_params; - base = sz - cnt; - for (i = 0; i < cnt; i++) { - int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); - if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) { - vld = VALID_BOX; - typed_arg = 1; - } else if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & (bit << 1)) { - vld = VALID_FLONUM; - typed_arg = 1; - } else - vld = VALID_VAL; - closure_stack[i + base] = vld; - } - } else { - base = sz; - } - - cnt = data->closure_size; - base = base - cnt; - stack_delta = data->max_let_depth - sz; - - for (i = 0; i < cnt; i++) { - q = map[i]; - if (q == self_pos) - self_pos_in_closure = i; - p = q + delta; - if ((q < 0) || (p >= depth) || (stack[p] <= VALID_UNINIT)) - scheme_ill_formed_code(port); - vld = stack[p]; - if (vld == VALID_VAL_NOCLEAR) - vld = VALID_VAL; - else if (vld == VALID_BOX_NOCLEAR) - vld = VALID_BOX; - - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - int pos = data->num_params + i; - int bit = ((mzshort)2 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); - if (map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) { - if (vld != VALID_FLONUM) - vld = VALID_NOT; - } else if (vld == VALID_FLONUM) - vld = VALID_NOT; - } else if (vld == VALID_FLONUM) - vld = VALID_NOT; - - closure_stack[i + base] = vld; - - if (procs) { - proc = scheme_hash_tree_get(procs, scheme_make_integer(p)); - if (proc) - new_procs = scheme_hash_tree_set(as_nonempty_procs(new_procs), - scheme_make_integer(i + base + stack_delta), - proc); - } - } - - if (typed_arg) { - if ((proc_with_refs_ok != 1) - && !argument_to_arity_error(app_rator, proc_with_refs_ok)) - scheme_ill_formed_code(port); - } - - if (SCHEME_RPAIRP(data->code)) { - /* Delay validation */ - Scheme_Object *vec; - vec = scheme_make_vector(9, NULL); - SCHEME_VEC_ELS(vec)[0] = SCHEME_CAR(data->code); - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)closure_stack; - SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)tls; - SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(num_toplevels); - SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(num_stxes); - SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(num_lifts); - SCHEME_VEC_ELS(vec)[6] = scheme_make_integer(self_pos_in_closure); - SCHEME_VEC_ELS(vec)[7] = new_procs ? (Scheme_Object *)new_procs : scheme_false; - SCHEME_VEC_ELS(vec)[8] = tl_use_map ? tl_use_map : scheme_false; - SCHEME_CAR(data->code) = vec; - } else - scheme_validate_closure(port, expr, closure_stack, tls, - num_toplevels, num_stxes, num_lifts, tl_use_map, - self_pos_in_closure, new_procs); -} - -static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct Validate_Clearing *vc, - int delta, char *stack) -{ - if ((vc->self_pos >= 0) - && SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type) - && !SCHEME_GET_LOCAL_FLAGS(rator) - && ((SCHEME_LOCAL_POS(rator) + delta) == vc->self_pos)) { - /* For a self call, the JIT needs the closure data to be intact. */ - int i, pos; - for (i = vc->self_count; i--; ) { - pos = i + vc->self_start; - if (stack[pos] <= VALID_UNINIT) - scheme_ill_formed_code(port); - } - } -} - -static void no_flo(int need_flonum, Mz_CPort *port) -{ - if (need_flonum) scheme_ill_formed_code(port); -} - -static void check_flo(Scheme_Object *expr, int need_flonum, Mz_CPort *port) -{ - if (need_flonum) { - if (!scheme_expr_produces_flonum(expr)) - scheme_ill_formed_code(port); - } -} - -#define CAN_RESET_STACK_SLOT 0 -#if !CAN_RESET_STACK_SLOT -# define WHEN_CAN_RESET_STACK_SLOT(x) 0 -#else -# define WHEN_CAN_RESET_STACK_SLOT(x) (x) -#endif - -void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - Scheme_Object *app_rator, int proc_with_refs_ok, - int result_ignored, - struct Validate_Clearing *vc, int tailpos, - int need_flonum, Scheme_Hash_Tree *procs) -{ - Scheme_Type type; - int did_one = 0, vc_merge = 0, vc_merge_start = 0; - -#ifdef DO_STACK_CHECK -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - void **pr; - int *args; - - args = MALLOC_N_ATOMIC(int, 10); - - p->ku.k.p1 = (void *)port; - p->ku.k.p2 = (void *)expr; - p->ku.k.p3 = (void *)stack; - p->ku.k.p4 = (void *)vc; - - args[0] = depth; - args[1] = letlimit; - args[2] = delta; - args[3] = num_toplevels; - args[4] = num_stxes; - args[5] = num_lifts; - args[6] = proc_with_refs_ok; - args[7] = result_ignored; - args[8] = tailpos; - args[9] = need_flonum; - - pr = MALLOC_N(void*, 5); - pr[0] = (void *)args; - pr[1] = (void *)app_rator; - pr[2] = (void *)tls; - pr[3] = (void *)procs; - pr[4] = tl_use_map; - - p->ku.k.p5 = (void *)pr; - - (void)scheme_handle_stack_overflow(validate_k); - - return; - } -#endif - - top: - if (did_one) { - if (app_rator) { - if (scheme_validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, - tls, num_toplevels, num_stxes, num_lifts, - tl_use_map)) - scheme_ill_formed_code(port); - app_rator = NULL; - } - proc_with_refs_ok = 0; - } else - did_one = 1; - - type = SCHEME_TYPE(expr); - - switch (type) { - case scheme_toplevel_type: - { - int c = SCHEME_TOPLEVEL_DEPTH(expr); - int d = c + delta; - int p = SCHEME_TOPLEVEL_POS(expr); - - no_flo(need_flonum, port); - - if ((c < 0) || (p < 0) || (d >= depth) - || (stack[d] != VALID_TOPLEVELS) - || (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0))) - || ((p >= num_toplevels) && (p < num_toplevels + num_stxes + (num_stxes ? 1 : 0)))) - scheme_ill_formed_code(port); - - if (tl_use_map) { - int p2 = ((p < num_toplevels) - ? p - : (num_stxes ? (p - num_stxes - 1) : p)); - if ((uintptr_t)tl_use_map & 0x1) { - if (p2 > 31) - scheme_ill_formed_code(port); - if (!((uintptr_t)tl_use_map & (1 << (p2 + 1)))) - scheme_ill_formed_code(port); - } else { - if (p2 >= (*(int *)tl_use_map * 32)) - scheme_ill_formed_code(port); - if (!(((int *)tl_use_map)[1 + (p2 / 32)] & (1 << (p2 & 31)))) - scheme_ill_formed_code(port); - } - } - - if ((proc_with_refs_ok != 1) - && !argument_to_arity_error(app_rator, proc_with_refs_ok)) { - if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { - /* It's a lift. Check that the lift is defined, and that it - doesn't want reference arguments. */ - int tp; - mzshort *a; - tp = p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); - a = tls[tp]; - if (a) { - if (a == (mzshort *)0x1) { - /* Ok */ - } else if (a[0] > 0) { - int i, cnt; - cnt = a[0]; - for (i = 0; i < cnt; i++) { - if (a[i] == 2) - scheme_ill_formed_code(port); - } - tls[tp] = (mzshort *)0x1; - } else { - /* a[0] is either 0 (top-level ref; shouldn't happen) or < 0 (wants some ref args) */ - scheme_ill_formed_code(port); - } - } else { - tls[tp] = (mzshort *)0x1; /* means "no ref args anywhere" */ - } - } - } - } - break; - case scheme_local_type: - { - int q = SCHEME_LOCAL_POS(expr); - int p = q + delta; - - if ((q < 0) || (p >= depth)) - scheme_ill_formed_code(port); - - if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) - no_flo(need_flonum, port); - - if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) { - if (stack[p] != VALID_FLONUM) - scheme_ill_formed_code(port); - } else if ((stack[p] != VALID_VAL) && (stack[p] != VALID_VAL_NOCLEAR)) { - if (result_ignored && ((stack[p] == VALID_BOX) - || (stack[p] == VALID_BOX_NOCLEAR) - || (stack[p] == VALID_FLONUM))) { - /* ok to look up and ignore box or flonum */ - } else if ((proc_with_refs_ok >= 2) - && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR)) - && scheme_validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 1, - tls, num_toplevels, num_stxes, num_lifts, - tl_use_map)) { - /* It's ok - the function wants us to pass it a box, and - we did. */ - app_rator = NULL; - } else - scheme_ill_formed_code(port); - } - - if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_CLEAR_ON_READ) { - if ((stack[p] == VALID_VAL_NOCLEAR) || (stack[p] == VALID_BOX_NOCLEAR)) - scheme_ill_formed_code(port); - if (p >= letlimit) - clearing_stack_push(vc, p, stack[p]); - stack[p] = VALID_NOT; - } else if (!(SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_OTHER_CLEARS)) { - if (stack[p] == VALID_BOX) { - if (p >= letlimit) - noclear_stack_push(vc, p); - stack[p] = VALID_BOX_NOCLEAR; - } else if (stack[p] == VALID_VAL) { - if (p >= letlimit) - noclear_stack_push(vc, p); - stack[p] = VALID_VAL_NOCLEAR; - } - } - - if (procs && !proc_with_refs_ok && !result_ignored) { - if (scheme_hash_tree_get(procs, scheme_make_integer(p))) - scheme_ill_formed_code(port); - } - } - break; - case scheme_local_unbox_type: - { - int q = SCHEME_LOCAL_POS(expr); - int p = q + delta; - - no_flo(need_flonum, port); - - if ((q < 0) || (p >= depth) || ((stack[p] != VALID_BOX) - && (stack[p] != VALID_BOX_NOCLEAR))) - scheme_ill_formed_code(port); - - if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_CLEAR_ON_READ) { - if (stack[p] == VALID_BOX_NOCLEAR) - scheme_ill_formed_code(port); - if (p >= letlimit) - clearing_stack_push(vc, p, stack[p]); - stack[p] = VALID_NOT; - } else if (!(SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_OTHER_CLEARS)) { - if (stack[p] == VALID_BOX) { - if (p >= letlimit) - noclear_stack_push(vc, p); - stack[p] = VALID_BOX_NOCLEAR; - } - } - } - break; - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)expr; - int i, n; - - check_flo(expr, need_flonum, port); - - n = app->num_args + 1; - - delta -= (n - 1); - if (delta < 0) - scheme_ill_formed_code(port); - memset(stack + delta, VALID_NOT, n - 1); - - for (i = 0; i < n; i++) { - scheme_validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs); - } - - if (tailpos) - check_self_call_valid(app->args[0], port, vc, delta, stack); - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; - - check_flo(expr, need_flonum, port); - - delta -= 1; - if (delta < 0) - scheme_ill_formed_code(port); - stack[delta] = VALID_NOT; - - scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 1, 0, vc, 0, 0, procs); - scheme_validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - app->rator, 2, 0, vc, 0, 0, procs); - - if (tailpos) - check_self_call_valid(app->rator, port, vc, delta, stack); - } - break; - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; - - check_flo(expr, need_flonum, port); - - delta -= 2; - if (delta < 0) - scheme_ill_formed_code(port); - stack[delta] = VALID_NOT; - stack[delta+1] = VALID_NOT; - - scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 1, 0, vc, 0, 0, procs); - scheme_validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - app->rator, 2, 0, vc, 0, 0, procs); - scheme_validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - app->rator, 3, 0, vc, 0, 0, procs); - - if (tailpos) - check_self_call_valid(app->rator, port, vc, delta, stack); - } - break; - case scheme_sequence_type: - case scheme_splice_sequence_type: - { - Scheme_Sequence *seq = (Scheme_Sequence *)expr; - int cnt; - int i; - - no_flo(need_flonum, port); - - cnt = seq->count; - - for (i = 0; i < cnt - 1; i++) { - scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 1, vc, 0, 0, procs); - } - - expr = seq->array[cnt - 1]; - goto top; - } - break; - case scheme_branch_type: - { - Scheme_Branch_Rec *b; - int vc_pos, vc_ncpos; - - no_flo(need_flonum, port); - - b = (Scheme_Branch_Rec *)expr; - scheme_validate_expr(port, b->test, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); - /* This is where letlimit is useful. It prevents let-assignment in the - "then" branch that could permit bad code in the "else" branch (or the - same thing with either branch affecting later code in a sequence). */ - letlimit = delta; - vc_pos = vc->stackpos; - vc_ncpos = vc->ncstackpos; - scheme_validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, result_ignored, vc, tailpos, 0, procs); - - /* Rewind clears and noclears, but also save the clears, - so that the branches' effects can be merged. */ - { - int i, j; - - if (!vc_merge) { - vc_merge = 1; - vc_merge_start = vc_pos; - } - - for (i = vc->stackpos - 2; i >= vc_pos; i -= 2) { - stack[vc->stack[i]] = vc->stack[i + 1]; - } - - for (i = vc->ncstackpos - 1; i >= vc_ncpos; i--) { - j = vc->ncstack[i]; - if (stack[j] == VALID_VAL_NOCLEAR) - stack[j] = VALID_VAL; - else if (stack[j] == VALID_BOX_NOCLEAR) - stack[j] = VALID_BOX; - } - vc->ncstackpos = vc_ncpos; - } - - expr = b->fbranch; - goto top; - } - break; - case scheme_with_cont_mark_type: - { - Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr; - - no_flo(need_flonum, port); - - scheme_validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); - scheme_validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); - expr = wcm->body; - goto top; - } - break; - case scheme_quote_syntax_type: - { - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)expr; - int c = qs->depth; - int i = qs->position; - int p = qs->midpoint; - int d = c + delta; - - no_flo(need_flonum, port); - - if ((c < 0) || (p < 0) || (d >= depth) - || (stack[d] != VALID_TOPLEVELS) - || (p != num_toplevels) - || (i >= num_stxes)) - scheme_ill_formed_code(port); - } - break; - case scheme_unclosed_procedure_type: - { - no_flo(need_flonum, port); - validate_unclosed_procedure(port, expr, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - app_rator, proc_with_refs_ok, -1, procs); - } - break; - case scheme_let_value_type: - { - Scheme_Let_Value *lv = (Scheme_Let_Value *)expr; - int q, p, c, i; - - scheme_validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); - /* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */ - - c = lv->count; - q = lv->position; - p = q + delta; - - for (i = 0; i < c; i++, p++) { - if ((q < 0) - || (SCHEME_LET_AUTOBOX(lv) && ((p >= depth) - || ((stack[p] != VALID_BOX) - && (stack[p] != VALID_BOX_NOCLEAR)))) - || (!SCHEME_LET_AUTOBOX(lv) && ((p >= letlimit) - || !(WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL) - || WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL_NOCLEAR) - || (stack[p] == VALID_UNINIT))))) - scheme_ill_formed_code(port); - - if (!SCHEME_LET_AUTOBOX(lv)) { - if (stack[p] != VALID_VAL_NOCLEAR) - stack[p] = VALID_VAL; - } - } - - expr = lv->body; - goto top; - } - break; - case scheme_let_void_type: - { - Scheme_Let_Void *lv = (Scheme_Let_Void *)expr; - int c, i; - - c = lv->count; - - if ((c < 0) || (c > delta)) - scheme_ill_formed_code(port); - - if (SCHEME_LET_AUTOBOX(lv)) { - for (i = 0; i < c; i++) { - stack[--delta] = VALID_BOX; - } - } else { - delta -= c; - memset(stack + delta, VALID_UNINIT, c); - } - - expr = lv->body; - goto top; - } - break; - case scheme_letrec_type: - { - Scheme_Letrec *l = (Scheme_Letrec *)expr; - int i, c; - - c = l->count; - - if ((c < 0) || (c + delta > depth)) - scheme_ill_formed_code(port); - - for (i = 0; i < c; i++) { - if (!SAME_TYPE(SCHEME_TYPE(l->procs[i]), scheme_unclosed_procedure_type)) - scheme_ill_formed_code(port); - } - - for (i = 0; i < c; i++) { -#if !CAN_RESET_STACK_SLOT - if (stack[delta + i] != VALID_UNINIT) - scheme_ill_formed_code(port); -#endif - stack[delta + i] = VALID_VAL; - if (SCHEME_CLOSURE_DATA_FLAGS(((Scheme_Closure_Data *)l->procs[i])) & CLOS_HAS_TYPED_ARGS) { - procs = scheme_hash_tree_set(as_nonempty_procs(procs), - scheme_make_integer(delta + i), - l->procs[i]); - } - } - - for (i = 0; i < c; i++) { - validate_unclosed_procedure(port, l->procs[i], stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 1, i, procs); - } - - expr = l->body; - goto top; - } - break; - case scheme_let_one_type: - { - Scheme_Let_One *lo = (Scheme_Let_One *)expr; - - --delta; - if (delta < 0) - scheme_ill_formed_code(port); - stack[delta] = VALID_UNINIT; - - scheme_validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs); - -#if !CAN_RESET_STACK_SLOT - if (stack[delta] != VALID_UNINIT) - scheme_ill_formed_code(port); -#endif - - if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_UNUSED) { - stack[delta] = VALID_NOT; - } else if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM) { - stack[delta] = VALID_FLONUM; - /* FIXME: need to check that lo->value produces a flonum */ - } else - stack[delta] = VALID_VAL; - - expr = lo->body; - goto top; - } - break; - - case scheme_define_values_type: - no_flo(need_flonum, port); - scheme_define_values_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_define_syntaxes_type: - no_flo(need_flonum, port); - scheme_define_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_define_for_syntax_type: - no_flo(need_flonum, port); - scheme_define_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_set_bang_type: - no_flo(need_flonum, port); - scheme_set_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_boxenv_type: - no_flo(need_flonum, port); - scheme_bangboxenv_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_begin0_sequence_type: - no_flo(need_flonum, port); - scheme_begin0_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_require_form_type: - no_flo(need_flonum, port); - scheme_top_level_require_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_varref_form_type: - no_flo(need_flonum, port); - scheme_ref_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_apply_values_type: - no_flo(need_flonum, port); - scheme_apply_values_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_case_lambda_sequence_type: - no_flo(need_flonum, port); - scheme_case_lambda_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - case scheme_module_type: - no_flo(need_flonum, port); - scheme_module_validate(expr, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - result_ignored, vc, tailpos, procs); - break; - default: - /* All values are definitely ok, except pre-closed closures. - Such a closure can refer back to itself, so we use a flag - to track cycles. Also check need_flonum. */ - if (SAME_TYPE(type, scheme_closure_type)) { - Scheme_Closure_Data *data; - no_flo(need_flonum, port); - expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr); - data = (Scheme_Closure_Data *)expr; - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_VALIDATED) { - /* Done with this one. */ - } else { - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_VALIDATED; - did_one = 0; - goto top; - } - } else if (SAME_TYPE(type, scheme_case_closure_type)) { - Scheme_Case_Lambda *seq; - int i; - seq = (Scheme_Case_Lambda *)expr; - for (i = 0; i < seq->count; i++) { - scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); - } - } else if (need_flonum) { - if (!SCHEME_FLOATP(expr)) - no_flo(need_flonum, port); - } - break; - } - - if (app_rator) - if (scheme_validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, - tls, num_toplevels, num_stxes, num_lifts, tl_use_map)) - scheme_ill_formed_code(port); - - if (vc_merge) { - /* Re-clear to merge effects from branches */ - int i, p; - for (i = vc_merge_start; i < vc->stackpos; i += 2) { - p = vc->stack[i]; - stack[p] = VALID_NOT; - } - } -} - -void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - int skip_refs_check) -{ - if (!SAME_TYPE(scheme_toplevel_type, SCHEME_TYPE(expr))) - scheme_ill_formed_code(port); - - scheme_validate_expr(port, expr, stack, tls, - depth, delta, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, skip_refs_check ? 1 : 0, 0, - make_clearing_stack(), 0, 0, NULL); -} - -void scheme_validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta, int letlimit) -{ - if (p >= 0) - p += delta; - - if ((p < 0) || (p >= letlimit) || (stack[p] != VALID_VAL)) - scheme_ill_formed_code(port); - - stack[p] = VALID_BOX; -} - -/*========================================================================*/ -/* [un]marshalling application, branch, sequence, wcm bytecode */ -/*========================================================================*/ - -#define BOOL(x) (x ? scheme_true : scheme_false) - -static Scheme_Object *write_application(Scheme_Object *obj) -{ - scheme_signal_error("app writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_application(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_sequence(Scheme_Object *obj) -{ - Scheme_Object *l; - int i; - - i = ((Scheme_Sequence *)obj)->count; - - l = scheme_null; - for (; i--; ) { - l = cons(scheme_protect_quote(((Scheme_Sequence *)obj)->array[i]), l); - } - - return l; -} - -static Scheme_Object *read_sequence(Scheme_Object *obj) -{ - return scheme_make_sequence_compilation(obj, 1); -} - -static Scheme_Object *read_sequence_save_first(Scheme_Object *obj) -{ - return scheme_make_sequence_compilation(obj, -2); -} - -static Scheme_Object *read_sequence_splice(Scheme_Object *obj) -{ - obj = scheme_make_sequence_compilation(obj, 1); - if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type)) - obj->type = scheme_splice_sequence_type; - return obj; -} - -static Scheme_Object *write_branch(Scheme_Object *obj) -{ - scheme_signal_error("branch writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_branch(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_with_cont_mark(Scheme_Object *obj) -{ - Scheme_With_Continuation_Mark *wcm; - - wcm = (Scheme_With_Continuation_Mark *)obj; - - return cons(scheme_protect_quote(wcm->key), - cons(scheme_protect_quote(wcm->val), - scheme_protect_quote(wcm->body))); -} - -static Scheme_Object *read_with_cont_mark(Scheme_Object *obj) -{ - Scheme_With_Continuation_Mark *wcm; - - if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj))) - return NULL; /* bad .zo */ - - wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - wcm->so.type = scheme_with_cont_mark_type; - wcm->key = SCHEME_CAR(obj); - wcm->val = SCHEME_CADR(obj); - wcm->body = SCHEME_CDR(SCHEME_CDR(obj)); - - return (Scheme_Object *)wcm; -} - -static Scheme_Object *write_quote_syntax(Scheme_Object *obj) -{ - Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; - - return cons(scheme_make_integer(qs->depth), - cons(scheme_make_integer(qs->position), - scheme_make_integer(qs->midpoint))); -} - -static Scheme_Object *read_quote_syntax(Scheme_Object *obj) -{ - Scheme_Quote_Syntax *qs; - Scheme_Object *a; - int c, i, p; - - if (!SCHEME_PAIRP(obj)) return NULL; - - a = SCHEME_CAR(obj); - c = SCHEME_INT_VAL(a); - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - a = SCHEME_CAR(obj); - i = SCHEME_INT_VAL(a); - - a = SCHEME_CDR(obj); - p = SCHEME_INT_VAL(a); - - qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); - qs->so.type = scheme_quote_syntax_type; - qs->depth = c; - qs->position = i; - qs->midpoint = p; - - return (Scheme_Object *)qs; -} - /*========================================================================*/ /* precise GC traversers */ /*========================================================================*/ @@ -13346,7 +5349,6 @@ static void register_traversers(void) { GC_REG_TRAV(scheme_rt_compile_info, mark_comp_info); GC_REG_TRAV(scheme_rt_saved_stack, mark_saved_stack); - GC_REG_TRAV(scheme_rt_validate_clearing, mark_validate_clearing); } END_XFORM_SKIP; diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 78f9e68169..3c83e2d984 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -184,8 +184,6 @@ static Scheme_Object *current_prompt_read(int, Scheme_Object **); static Scheme_Object *current_read(int, Scheme_Object **); static Scheme_Object *current_get_read_input_port(int, Scheme_Object **); -static Scheme_Object *write_compiled_closure(Scheme_Object *obj); -static Scheme_Object *read_compiled_closure(Scheme_Object *obj); static Scheme_Object * scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key, Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta, @@ -577,11 +575,6 @@ scheme_init_fun (Scheme_Env *env) MZCONFIG_READ_INPUT_PORT_HANDLER), env); - scheme_install_type_writer(scheme_unclosed_procedure_type, - write_compiled_closure); - scheme_install_type_reader(scheme_unclosed_procedure_type, - read_compiled_closure); - REGISTER_SO(certify_mode_symbol); REGISTER_SO(transparent_symbol); REGISTER_SO(transparent_binding_symbol); @@ -866,1199 +859,6 @@ int scheme_has_method_property(Scheme_Object *code) return SCHEME_TRUEP(scheme_stx_property(code, is_method_symbol, NULL)); } -/*========================================================================*/ -/* closures (run time and compilation) */ -/*========================================================================*/ - -Scheme_Object * -scheme_make_closure(Scheme_Thread *p, Scheme_Object *code, int close) - /* Creates a closure at run-time (or an empty closure at compile - time; note that the byte-code marshaller in print.c can handle - empty closures for that reason). */ -{ - Scheme_Closure_Data *data; - Scheme_Closure *closure; - GC_CAN_IGNORE Scheme_Object **runstack; - GC_CAN_IGNORE Scheme_Object **dest; - GC_CAN_IGNORE mzshort *map; - int i; - - data = (Scheme_Closure_Data *)code; - -#ifdef MZ_USE_JIT - if (data->u.native_code) { - Scheme_Object *nc; - - nc = scheme_make_native_closure(data->u.native_code); - - if (close) { - runstack = MZ_RUNSTACK; - dest = ((Scheme_Native_Closure *)nc)->vals; - map = data->closure_map; - i = data->closure_size; - - /* Copy data into the closure: */ - while (i--) { - dest[i] = runstack[map[i]]; - } - } - - return nc; - } -#endif - - i = data->closure_size; - - closure = (Scheme_Closure *) - scheme_malloc_tagged(sizeof(Scheme_Closure) - + (i - 1) * sizeof(Scheme_Object *)); - - closure->so.type = scheme_closure_type; - SCHEME_COMPILED_CLOS_CODE(closure) = data; - - if (!close || !i) - return (Scheme_Object *)closure; - - runstack = MZ_RUNSTACK; - dest = closure->vals; - map = data->closure_map; - - /* Copy data into the closure: */ - while (i--) { - dest[i] = runstack[map[i]]; - } - - return (Scheme_Object *)closure; -} - -Scheme_Closure *scheme_malloc_empty_closure() -{ - Scheme_Closure *cl; - - cl = (Scheme_Closure *)scheme_malloc_tagged(sizeof(Scheme_Closure) - sizeof(Scheme_Object *)); - cl->so.type = scheme_closure_type; - - return cl; -} - -Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context) - /* If lr is supplied as a letrec binding this closure, it may be used - for JIT compilation. */ -{ -#ifdef MZ_USE_JIT - Scheme_Closure_Data *data = (Scheme_Closure_Data *)code, *data2; - - /* We need to cache clones to support multiple references - to a zero-sized closure in bytecode. We need either a clone - or native code, and context determines which field is relevant, - so we put the two possibilities in a union `u'. */ - - if (!context) - data2 = data->u.jit_clone; - else - data2 = NULL; - - if (!data2) { - Scheme_Native_Closure_Data *ndata; - - data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data); - memcpy(data2, code, sizeof(Scheme_Closure_Data)); - - data2->context = context; - - ndata = scheme_generate_lambda(data2, 1, NULL); - data2->u.native_code = ndata; - - if (!context) - data->u.jit_clone = data2; - } - - /* If it's zero-sized, then create closure now */ - if (!data2->closure_size) - return scheme_make_native_closure(data2->u.native_code); - - return (Scheme_Object *)data2; -#endif - - return code; -} - -void scheme_delay_load_closure(Scheme_Closure_Data *data) -{ - if (SCHEME_RPAIRP(data->code)) { - Scheme_Object *v, *vinfo = NULL; - - v = SCHEME_CAR(data->code); - if (SCHEME_VECTORP(v)) { - /* Has info for delayed validation */ - vinfo = v; - v = SCHEME_VEC_ELS(vinfo)[0]; - } - v = scheme_load_delayed_code(SCHEME_INT_VAL(v), - (struct Scheme_Load_Delay *)SCHEME_CDR(data->code)); - data->code = v; - - if (vinfo) { - scheme_validate_closure(NULL, - (Scheme_Object *)data, - (char *)SCHEME_VEC_ELS(vinfo)[1], - (Validate_TLS)SCHEME_VEC_ELS(vinfo)[2], - SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[3]), - SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[4]), - SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[5]), - (SCHEME_TRUEP(SCHEME_VEC_ELS(vinfo)[8]) - ? (void *)SCHEME_VEC_ELS(vinfo)[8] - : NULL), - SCHEME_INT_VAL(SCHEME_VEC_ELS(vinfo)[6]), - (SCHEME_TRUEP(SCHEME_VEC_ELS(vinfo)[7]) - ? (Scheme_Hash_Tree *)SCHEME_VEC_ELS(vinfo)[7] - : NULL)); - } - } -} - -/* Closure_Info is used to store extra closure information - before a closure mapping is resolved. */ -typedef struct { - MZTAG_IF_REQUIRED - int *local_flags; /* for arguments from compile pass, flonum info updated in optimize pass */ - mzshort base_closure_size; /* doesn't include top-level (if any) */ - mzshort *base_closure_map; - char *flonum_map; /* NULL when has_flomap set => no flonums */ - char has_tl, has_flomap, has_nonleaf; - int body_size, body_psize; -} Closure_Info; - -Scheme_Object * -scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int context) -{ - Scheme_Closure_Data *data; - Scheme_Object *code, *ctx; - Closure_Info *cl; - mzshort dcs, *dcm; - int i, cnt; - Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL; - - data = (Scheme_Closure_Data *)_data; - - info->single_result = 1; - info->preserves_marks = 1; - - info = scheme_optimize_info_add_frame(info, data->num_params, data->num_params, - SCHEME_LAMBDA_FRAME); - - info->vclock += 1; /* model delayed evaluation as vclock increment */ - - /* For reporting warnings: */ - if (info->context && SCHEME_PAIRP(info->context)) - ctx = scheme_make_pair((Scheme_Object *)data, - SCHEME_CDR(info->context)); - else if (info->context) - ctx = scheme_make_pair((Scheme_Object *)data, info->context); - else - ctx = (Scheme_Object *)data; - info->context = ctx; - - cl = (Closure_Info *)data->closure_map; - for (i = 0; i < data->num_params; i++) { - if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) - scheme_optimize_mutated(info, i); - - cnt = ((cl->local_flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); - if (cnt == 1) { - last_once_used = scheme_make_once_used(NULL, i, info->vclock, last_once_used); - if (!first_once_used) first_once_used = last_once_used; - scheme_optimize_propagate(info, i, (Scheme_Object *)last_once_used, 1); - } - } - - code = scheme_optimize_expr(data->code, info, 0); - - for (i = 0; i < data->num_params; i++) { - if (scheme_optimize_is_flonum_arg(info, i, 1)) - cl->local_flags[i] |= SCHEME_WAS_FLONUM_ARGUMENT; - } - - while (first_once_used) { - if (first_once_used->vclock < 0) { - /* no longer used once, due to binding propagation */ - cl->local_flags[first_once_used->pos] |= SCHEME_USE_COUNT_MASK; - } - first_once_used = first_once_used->next; - } - - if (info->single_result) - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SINGLE_RESULT; - else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT) - SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_SINGLE_RESULT; - - if (info->preserves_marks) - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_PRESERVES_MARKS; - else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS) - SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_PRESERVES_MARKS; - - if ((info->single_result > 0) && (info->preserves_marks > 0) - && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) - SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_RESULT_TENTATIVE; - - data->code = code; - - /* Remembers positions of used vars (and unsets usage for this level) */ - scheme_env_make_closure_map(info, &dcs, &dcm); - cl->base_closure_size = dcs; - cl->base_closure_map = dcm; - if (scheme_env_uses_toplevel(info)) - cl->has_tl = 1; - else - cl->has_tl = 0; - cl->body_size = info->size; - cl->body_psize = info->psize; - cl->has_nonleaf = info->has_nonleaf; - - info->size++; - - data->closure_size = (cl->base_closure_size - + (cl->has_tl ? 1 : 0)); - - scheme_optimize_info_done(info); - - return (Scheme_Object *)data; -} - -char *scheme_get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok) -{ - Closure_Info *cl = (Closure_Info *)data->closure_map; - - if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - || (arg_n != data->num_params)) { - *ok = 0; - return NULL; - } - - if (cl->has_flomap && !cl->flonum_map) { - *ok = 0; - return NULL; - } - - *ok = 1; - return cl->flonum_map; -} - -void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map) -{ - Closure_Info *cl = (Closure_Info *)data->closure_map; - int i; - - if (!cl->flonum_map) { - cl->has_flomap = 1; - cl->flonum_map = flonum_map; - } - - if (flonum_map) { - for (i = data->num_params; i--; ) { - if (flonum_map[i]) break; - } - - if (i < 0) { - cl->flonum_map = NULL; - } - } -} - -void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2) -{ - Closure_Info *cl1 = (Closure_Info *)data1->closure_map; - Closure_Info *cl2 = (Closure_Info *)data2->closure_map; - - if (cl1->has_flomap) { - if (!cl1->flonum_map || !cl2->has_flomap) { - cl2->has_flomap = 1; - cl2->flonum_map = cl1->flonum_map; - } else if (cl2->flonum_map) { - int i; - for (i = data1->num_params; i--; ) { - if (cl1->flonum_map[i] != cl2->flonum_map[i]) { - cl2->flonum_map = NULL; - cl1->flonum_map = NULL; - break; - } - } - } else { - cl1->flonum_map = NULL; - } - } else if (cl2->has_flomap) { - cl1->has_flomap = 1; - cl1->flonum_map = cl2->flonum_map; - } -} - -Scheme_Object *scheme_clone_closure_compilation(int dup_ok, Scheme_Object *_data, Optimize_Info *info, int delta, int closure_depth) -{ - Scheme_Closure_Data *data, *data2; - Scheme_Object *body; - Closure_Info *cl; - int *flags, sz; - char *flonum_map; - - data = (Scheme_Closure_Data *)_data; - - body = scheme_optimize_clone(dup_ok, data->code, info, delta, closure_depth + data->num_params); - if (!body) return NULL; - - data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data); - memcpy(data2, data, sizeof(Scheme_Closure_Data)); - - data2->code = body; - - cl = MALLOC_ONE_RT(Closure_Info); - memcpy(cl, data->closure_map, sizeof(Closure_Info)); - data2->closure_map = (mzshort *)cl; - - /* We don't have to update base_closure_map, because - it will get re-computed as the closure is re-optimized. */ - - sz = sizeof(int) * data2->num_params; - flags = (int *)scheme_malloc_atomic(sz); - memcpy(flags, cl->local_flags, sz); - cl->local_flags = flags; - - if (cl->flonum_map) { - sz = data2->num_params; - flonum_map = (char *)scheme_malloc_atomic(sz); - memcpy(flonum_map, cl->flonum_map, sz); - cl->flonum_map = flonum_map; - } - - return (Scheme_Object *)data2; -} - -Scheme_Object *scheme_shift_closure_compilation(Scheme_Object *_data, int delta, int after_depth) -{ - Scheme_Object *expr; - Scheme_Closure_Data *data = (Scheme_Closure_Data *)_data; - - expr = scheme_optimize_shift(data->code, delta, after_depth + data->num_params); - data->code = expr; - - return _data; -} - -Scheme_Object *scheme_sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_pos) -{ - Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; - Scheme_Object *code; - int i, size, has_tl = 0; - - size = data->closure_size; - if (size) { - if (info->stackpos + data->closure_map[size - 1] == info->tlpos) { - has_tl = 1; - --size; - } - } - - if (!info->pass) { - for (i = size; i--; ) { - scheme_sfs_used(info, data->closure_map[i]); - } - } else { - /* Check whether we need to zero out any stack positions - after capturing them in a closure: */ - Scheme_Object *clears = scheme_null; - - if (info->ip < info->max_nontail) { - int pos, ip; - for (i = size; i--; ) { - pos = data->closure_map[i] + info->stackpos; - if (pos < info->depth) { - ip = info->max_used[pos]; - if ((ip == info->ip) - && (ip < info->max_calls[pos])) { - pos -= info->stackpos; - clears = scheme_make_pair(scheme_make_integer(pos), - clears); - } - } - } - } - - return scheme_sfs_add_clears(expr, clears, 0); - } - - if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SFS)) { - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SFS; - info = scheme_new_sfs_info(data->max_let_depth); - scheme_sfs_push(info, data->closure_size + data->num_params, 1); - - if (has_tl) - info->tlpos = info->stackpos + data->closure_size - 1; - - if (self_pos >= 0) { - for (i = size; i--; ) { - if (data->closure_map[i] == self_pos) { - info->selfpos = info->stackpos + i; - info->selfstart = info->stackpos; - info->selflen = data->closure_size; - break; - } - } - } - - code = scheme_sfs(data->code, info, data->max_let_depth); - - /* If any arguments go unused, and if there's a non-tail, - non-immediate call in the body, then we flush the - unused arguments at the start of the body. We assume that - the closure values are used (otherwise they wouldn't - be in the closure). */ - if (info->max_nontail) { - int i, pos, cnt; - Scheme_Object *clears = scheme_null; - - cnt = data->num_params; - for (i = 0; i < cnt; i++) { - pos = data->max_let_depth - (cnt - i); - if (!info->max_used[pos]) { - pos = i + data->closure_size; - clears = scheme_make_pair(scheme_make_integer(pos), - clears); - } - } - - if (SCHEME_PAIRP(clears)) - code = scheme_sfs_add_clears(code, clears, 1); - - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR; - } - - data->code = code; - } - - return expr; -} - -int scheme_closure_body_size(Scheme_Closure_Data *data, int check_assign, - Optimize_Info *info, int *is_leaf) -{ - int i; - Closure_Info *cl; - - cl = (Closure_Info *)data->closure_map; - - if (check_assign) { - /* Don't try to inline if any arguments are mutated: */ - for (i = data->num_params; i--; ) { - if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) - return -1; - } - } - - if (is_leaf) - *is_leaf = !cl->has_nonleaf; - - return cl->body_size + ((info && info->use_psize) ? cl->body_psize : 0); -} - -int scheme_closure_has_top_level(Scheme_Closure_Data *data) -{ - Closure_Info *cl; - - cl = (Closure_Info *)data->closure_map; - - return cl->has_tl; -} - -int scheme_closure_argument_flags(Scheme_Closure_Data *data, int i) -{ - return ((Closure_Info *)data->closure_map)->local_flags[i]; -} - -XFORM_NONGCING static int boxmap_size(int n) -{ - return ((2 * n) + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT; -} - -static mzshort *allocate_boxmap(int n) -{ - mzshort *boxmap; - int size; - - size = boxmap_size(n); - boxmap = MALLOC_N_ATOMIC(mzshort, size); - memset(boxmap, 0, size * sizeof(mzshort)); - - return boxmap; -} - -XFORM_NONGCING static void boxmap_set(mzshort *boxmap, int j, int bit, int delta) -{ - boxmap[delta + ((2 * j) / BITS_PER_MZSHORT)] |= ((mzshort)bit << ((2 * j) & (BITS_PER_MZSHORT - 1))); -} - -XFORM_NONGCING static int boxmap_get(mzshort *boxmap, int j, int bit) -{ - if (boxmap[(2 * j) / BITS_PER_MZSHORT] & ((mzshort)bit << ((2 * j) & (BITS_PER_MZSHORT - 1)))) - return 1; - else - return 0; -} - -Scheme_Object * -scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, - int can_lift, int convert, int just_compute_lift, - Scheme_Object *precomputed_lift) -{ - Scheme_Closure_Data *data; - int i, closure_size, offset, np, num_params, expanded_already = 0; - int has_tl, convert_size, need_lift; - mzshort *oldpos, *closure_map, *new_closure_map; - Closure_Info *cl; - Resolve_Info *new_info; - Scheme_Object *lifted, *result, *lifteds = NULL; - Scheme_Hash_Table *captured = NULL; - mzshort *convert_map, *convert_boxes = NULL; - - data = (Scheme_Closure_Data *)_data; - cl = (Closure_Info *)data->closure_map; - if (!just_compute_lift) - data->iso.so.type = scheme_unclosed_procedure_type; - - if (convert || can_lift) { - if (!convert && !scheme_resolving_in_procedure(info)) - can_lift = 0; /* no point in lifting when outside of a lambda or letrec */ - if (!info->lifts) - can_lift = 0; - } - - /* We have to perform a small bit of constant propagation here. - Procedures closed only over top-level bindings are lifted during - this pass. Some of the captured bindings from this phase may - refer to a lifted procedure. In that case, we can replace the - lexical reference with a direct reference to the top-level - binding, which means that we can drop the binding from the - closure. */ - - closure_size = data->closure_size; - if (cl->flonum_map) { - int at_least_one = 0; - for (i = data->num_params; i--; ) { - if (cl->flonum_map[i]) { - if (cl->local_flags[i] & SCHEME_WAS_FLONUM_ARGUMENT) - at_least_one = 1; - else - cl->flonum_map[i] = 0; - } - } - if (at_least_one) { - closure_size += boxmap_size(data->num_params + closure_size); - expanded_already = 1; - } else - cl->flonum_map = NULL; - } - closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size); - if (cl->flonum_map) - memset(closure_map, 0, sizeof(mzshort) * closure_size); - - has_tl = cl->has_tl; - if (has_tl && !can_lift) - convert = 0; - - /* Locals in closure are first: */ - oldpos = cl->base_closure_map; - offset = 0; - for (i = 0; i < cl->base_closure_size; i++) { - int li, flags; - li = scheme_resolve_info_lookup(info, oldpos[i], &flags, &lifted, 0); - if (lifted) { - /* Drop lifted binding from closure. */ - if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type) - || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type)) { - has_tl = 1; - if (!can_lift) - convert = 0; - } - /* If the lifted binding is for a converted closure, - we may need to add more bindings to this closure. */ - if (SCHEME_RPAIRP(lifted)) { - lifteds = scheme_make_raw_pair(lifted, lifteds); - } - } else { - closure_map[offset] = li; - if (convert && (flags & (SCHEME_INFO_BOXED | SCHEME_INFO_FLONUM_ARG))) { - /* The only problem with a boxed/flonum variable is that - it's more difficult to validate. We have to track - which arguments are boxes. And the resulting procedure - must be used only in application positions. */ - if (!convert_boxes) - convert_boxes = allocate_boxmap(cl->base_closure_size); - boxmap_set(convert_boxes, offset, (flags & SCHEME_INFO_BOXED) ? 1 : 2, 0); - } else { - /* Currently, we only need flonum information as a closure type */ - if (flags & SCHEME_INFO_FLONUM_ARG) { - if (!expanded_already) { - closure_size += boxmap_size(data->num_params + closure_size); - new_closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size); - memset(new_closure_map, 0, sizeof(mzshort) * closure_size); - memcpy(new_closure_map, closure_map, sizeof(mzshort) * data->closure_size); - closure_map = new_closure_map; - expanded_already = 1; - } - boxmap_set(closure_map, data->num_params + offset, 2, data->closure_size); - } - } - offset++; - } - } - - /* Add bindings introduced by closure conversion. The `captured' - table maps old positions to new positions. */ - while (lifteds) { - int j, cnt, boxed, flonumed; - Scheme_Object *vec, *loc; - - if (!captured) { - captured = scheme_make_hash_table(SCHEME_hash_ptr); - for (i = 0; i < offset; i++) { - int cp; - cp = i; - if (convert_boxes) { - if (boxmap_get(convert_boxes, i, 1)) - cp = -((2 * cp) + 1); - else if (boxmap_get(convert_boxes, i, 2)) - cp = -((2 * cp) + 2); - } - scheme_hash_set(captured, scheme_make_integer(closure_map[i]), scheme_make_integer(cp)); - } - } - - lifted = SCHEME_CAR(lifteds); - vec = SCHEME_CDR(lifted); - cnt = SCHEME_VEC_SIZE(vec); - --cnt; - for (j = 0; j < cnt; j++) { - loc = SCHEME_VEC_ELS(vec)[j+1]; - if (SCHEME_BOXP(loc)) { - loc = SCHEME_BOX_VAL(loc); - boxed = 1; - flonumed = 0; - } else if (SCHEME_VECTORP(loc)) { - loc = SCHEME_VEC_ELS(loc)[0]; - boxed = 0; - flonumed = 1; - } else { - boxed = 0; - flonumed = 0; - } - i = SCHEME_LOCAL_POS(loc); - if (!scheme_hash_get(captured, scheme_make_integer(i))) { - /* Need to capture an extra binding: */ - int cp; - cp = captured->count; - if (boxed) - cp = -((2 * cp) + 1); - else if (flonumed) - cp = -((2 * cp) + 2); - scheme_hash_set(captured, scheme_make_integer(i), scheme_make_integer(cp)); - } - } - - lifteds = SCHEME_CDR(lifteds); - } - - if (captured && (captured->count > offset)) { - /* We need to extend the closure map. All the info - is in captured, so just build it from scratch. */ - int old_pos, j, new_size; - new_size = (captured->count + (has_tl ? 1 : 0)); - if (cl->flonum_map) - new_size += boxmap_size(data->num_params + new_size); - closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * new_size); - if (cl->flonum_map) - memset(closure_map, 0, sizeof(mzshort) * new_size); - offset = captured->count; - convert_boxes = NULL; - for (j = captured->size; j--; ) { - if (captured->vals[j]) { - int cp; - cp = SCHEME_INT_VAL(captured->vals[j]); - old_pos = SCHEME_INT_VAL(captured->keys[j]); - if (cp < 0) { - /* Boxed or flonum */ - int bit; - cp = -cp; - if (cp & 0x1) { - cp = (cp - 1) / 2; - bit = 1; - } else { - cp = (cp - 2) / 2; - bit = 2; - } - if (!convert_boxes) - convert_boxes = allocate_boxmap(offset); - boxmap_set(convert_boxes, cp, bit, 0); - } - closure_map[cp] = old_pos; - } - } - } - - if (convert - && (offset || !has_tl) /* either need args, or treat as convert because it's fully closed */ - ) { - /* Take over closure_map to be the convert map, instead. */ - convert_map = closure_map; - convert_size = offset; - - if (has_tl || convert_boxes || cl->flonum_map) { - int new_boxes_size; - int sz; - new_boxes_size = boxmap_size(convert_size + data->num_params + (has_tl ? 1 : 0)); - sz = ((has_tl ? sizeof(mzshort) : 0) + new_boxes_size * sizeof(mzshort)); - closure_map = (mzshort *)scheme_malloc_atomic(sz); - memset(closure_map, 0, sz); - if (convert_boxes) { - int bsz; - bsz = boxmap_size(convert_size); - memcpy(closure_map XFORM_OK_PLUS (has_tl ? 1 : 0), - convert_boxes, - bsz * sizeof(mzshort)); - } - } else - closure_map = NULL; - offset = 0; - } else { - convert = 0; - convert_map = NULL; - convert_size = 0; - convert_boxes = NULL; - } - - /* Then the pointer to globals, if any: */ - if (has_tl) { - /* GLOBAL ASSUMPTION: jit.c assumes that the array - of globals is the last item in the closure; grep - for "GLOBAL ASSUMPTION" in jit.c and mzmark.c */ - int li; - li = scheme_resolve_toplevel_pos(info); - closure_map[offset] = li; - offset++; - } - - /* Reset closure_size, in case a lifted variable was removed: */ - closure_size = offset; - if (!just_compute_lift) { - data->closure_size = closure_size; - if (convert && convert_boxes) - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_TYPED_ARGS; - } - - /* Set up environment mapping, initialized for arguments: */ - - np = num_params = data->num_params; - if ((data->num_params == 1) - && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - && !(cl->local_flags[0] & SCHEME_WAS_USED) - && !convert) { - /* (lambda args E) where args is not in E => drop the argument */ - new_info = scheme_resolve_info_extend(info, 0, 1, cl->base_closure_size); - num_params = 0; - if (!just_compute_lift) - data->num_params = 0; - } else { - new_info = scheme_resolve_info_extend(info, data->num_params, data->num_params, - cl->base_closure_size + data->num_params); - for (i = 0; i < data->num_params; i++) { - scheme_resolve_info_add_mapping(new_info, i, i + closure_size + convert_size, - (((cl->local_flags[i] & SCHEME_WAS_SET_BANGED) - ? SCHEME_INFO_BOXED - : 0) - | ((cl->flonum_map && cl->flonum_map[i]) - ? SCHEME_INFO_FLONUM_ARG - : 0)), - NULL); - if (cl->flonum_map && cl->flonum_map[i]) - boxmap_set(closure_map, i + convert_size, 2, closure_size); - } - if (expanded_already && !just_compute_lift) - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_TYPED_ARGS; - } - - /* Extend mapping to go from old locations on the stack (as if bodies were - evaluated immediately) to new locations (where closures - effectively shift and compact values on the stack). - - We don't have to include bindings added because an oiriginal - binding was lifted (i.e., the extra bindings in `captured'), - because they don't appear in the body. Instead, they are - introduced directly in resolved form through the `lifted' info. - That means, though, that we need to transform the `lifted' - mapping. */ - if (has_tl && convert) { - /* Skip handle for globals */ - offset = 1; - } else { - offset = 0; - } - for (i = 0; i < cl->base_closure_size; i++) { - int p = oldpos[i], flags; - - if (p < 0) - p -= np; - else - p += np; - - flags = scheme_resolve_info_flags(info, oldpos[i], &lifted); - - if (lifted && SCHEME_RPAIRP(lifted)) { - /* Convert from a vector of local references to an array of - positions. */ - Scheme_Object *vec, *loc, **ca; - mzshort *cmap, *boxmap = NULL; - int sz, j, cp; - - vec = SCHEME_CDR(lifted); - sz = SCHEME_VEC_SIZE(vec); - --sz; - cmap = MALLOC_N_ATOMIC(mzshort, sz); - for (j = 0; j < sz; j++) { - loc = SCHEME_VEC_ELS(vec)[j+1]; - if (SCHEME_BOXP(loc)) { - if (!boxmap) - boxmap = allocate_boxmap(sz); - boxmap_set(boxmap, j, 1, 0); - loc = SCHEME_BOX_VAL(loc); - } else if (SCHEME_VECTORP(loc)) { - if (!boxmap) - boxmap = allocate_boxmap(sz); - boxmap_set(boxmap, j, 2, 0); - loc = SCHEME_VEC_ELS(loc)[0]; - } - loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc))); - cp = SCHEME_INT_VAL(loc); - if (cp < 0) { - cp = -cp; - if (cp & 0x1) - cp = (cp - 1) / 2; - else - cp = (cp - 2) / 2; - } - cmap[j] = cp + (has_tl && convert ? 1 : 0); - } - - ca = MALLOC_N(Scheme_Object *, 4); - ca[0] = scheme_make_integer(sz); - ca[1] = (Scheme_Object *)cmap; - ca[2] = SCHEME_VEC_ELS(vec)[0]; - ca[3] = (Scheme_Object *)boxmap; - - lifted = scheme_make_raw_pair(SCHEME_CAR(lifted), (Scheme_Object *)ca); - } - - scheme_resolve_info_add_mapping(new_info, p, lifted ? 0 : offset++, flags, lifted); - } - if (has_tl) { - if (convert) - offset = 0; /* other closure elements converted to arguments */ - else - offset = closure_size - 1; - scheme_resolve_info_set_toplevel_pos(new_info, offset); - } - - if (!just_compute_lift) - data->closure_map = closure_map; - - new_info->in_proc = 1; - - if (!just_compute_lift) { - Scheme_Object *code; - code = scheme_resolve_expr(data->code, new_info); - data->code = code; - - data->max_let_depth = (new_info->max_let_depth - + num_params - + closure_size - + convert_size - + SCHEME_TAIL_COPY_THRESHOLD); - - data->tl_map = new_info->tl_map; - - /* Add code to box set!ed argument variables: */ - for (i = 0; i < num_params; i++) { - if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) { - int j = i + closure_size + convert_size; - Scheme_Object *bcode; - - bcode = scheme_alloc_object(); - bcode->type = scheme_boxenv_type; - SCHEME_PTR1_VAL(bcode) = scheme_make_integer(j); - SCHEME_PTR2_VAL(bcode) = data->code; - - data->code = bcode; - } - } - } - - if ((closure_size == 1) - && can_lift - && has_tl - && info->lifts) { - need_lift = 1; - } else - need_lift = 0; - - if (convert) { - num_params += convert_size; - if (!just_compute_lift) - data->num_params = num_params; - } - - /* If the closure is empty, create the closure now */ - if (!closure_size) { - if (precomputed_lift) { - result = SCHEME_CAR(precomputed_lift); - if (!just_compute_lift) - ((Scheme_Closure *)result)->code = data; - } else { - if (just_compute_lift) - result = (Scheme_Object *)scheme_malloc_empty_closure(); - else - result = scheme_make_closure(NULL, (Scheme_Object *)data, 0); - } - } else - result = (Scheme_Object *)data; - - if (need_lift) { - if (just_compute_lift) { - if (just_compute_lift > 1) - result = scheme_resolve_invent_toplevel(info); - else - result = scheme_resolve_generate_stub_lift(); - } else { - Scheme_Object *tl, *defn_tl; - if (precomputed_lift) { - tl = precomputed_lift; - if (SCHEME_RPAIRP(tl)) - tl = SCHEME_CAR(tl); - } else { - tl = scheme_resolve_invent_toplevel(info); - } - defn_tl = scheme_resolve_invented_toplevel_to_defn(info, tl); - scheme_resolve_lift_definition(info, defn_tl, result); - if (has_tl) - closure_map[0] = 0; /* globals for closure creation will be at 0 after lifting */ - result = tl; - } - } else { - scheme_merge_resolve_tl_map(info, new_info); - } - - if (convert) { - Scheme_Object **ca, *arity; - - if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) { - arity = scheme_box(scheme_make_integer(num_params - convert_size - 1)); - } else { - arity = scheme_make_integer(num_params - convert_size); - } - - ca = MALLOC_N(Scheme_Object *, 4); - ca[0] = scheme_make_integer(convert_size); - ca[1] = (Scheme_Object *)convert_map; - ca[2] = arity; - ca[3] = (Scheme_Object *)convert_boxes; - - if (precomputed_lift) { - SCHEME_CAR(precomputed_lift) = result; - SCHEME_CDR(precomputed_lift) = (Scheme_Object *)ca; - result = precomputed_lift; - } else - result = scheme_make_raw_pair(result, (Scheme_Object *)ca); - } - - return result; -} - -Scheme_Object *scheme_source_to_name(Scheme_Object *code) - /* Makes up a procedure name when there's not a good one in the source: */ -{ - Scheme_Stx *cstx = (Scheme_Stx *)code; - if ((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) { - char buf[50], src[20]; - Scheme_Object *name; - - if (cstx->srcloc->src && SCHEME_PATHP(cstx->srcloc->src)) { - if (SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) < 20) - memcpy(src, SCHEME_BYTE_STR_VAL(cstx->srcloc->src), SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) + 1); - else { - memcpy(src, SCHEME_BYTE_STR_VAL(cstx->srcloc->src) + SCHEME_BYTE_STRLEN_VAL(cstx->srcloc->src) - 19, 20); - src[0] = '.'; - src[1] = '.'; - src[2] = '.'; - } - } else { - return NULL; - } - - if (cstx->srcloc->line >= 0) { - sprintf(buf, "%s%s%" PRIdPTR ":%" PRIdPTR, - src, (src[0] ? ":" : ""), cstx->srcloc->line, cstx->srcloc->col - 1); - } else { - sprintf(buf, "%s%s%" PRIdPTR, - src, (src[0] ? "::" : ""), cstx->srcloc->pos); - } - - name = scheme_intern_exact_symbol(buf, strlen(buf)); - return name; - } - - return NULL; -} - -Scheme_Object *combine_name_with_srcloc(Scheme_Object *name, Scheme_Object *code, int src_based_name) -{ - Scheme_Stx *cstx = (Scheme_Stx *)code; - - if (((cstx->srcloc->col >= 0) || (cstx->srcloc->pos >= 0)) - && cstx->srcloc->src) { - Scheme_Object *vec; - vec = scheme_make_vector(7, NULL); - SCHEME_VEC_ELS(vec)[0] = name; - SCHEME_VEC_ELS(vec)[1] = cstx->srcloc->src; - if (cstx->srcloc->line >= 0) { - SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(cstx->srcloc->line); - SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(cstx->srcloc->col-1); - } else { - SCHEME_VEC_ELS(vec)[2] = scheme_false; - SCHEME_VEC_ELS(vec)[3] = scheme_false; - } - if (cstx->srcloc->pos >= 0) - SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(cstx->srcloc->pos); - else - SCHEME_VEC_ELS(vec)[4] = scheme_false; - if (cstx->srcloc->span >= 0) - SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(cstx->srcloc->span); - else - SCHEME_VEC_ELS(vec)[5] = scheme_false; - SCHEME_VEC_ELS(vec)[6] = (src_based_name ? scheme_true : scheme_false); - - return vec; - } - - return name; -} - -Scheme_Object *scheme_build_closure_name(Scheme_Object *code, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *name; - - name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL); - if (name && SCHEME_SYMBOLP(name)) { - name = combine_name_with_srcloc(name, code, 0); - } else if (name && SCHEME_VOIDP(name)) { - name = scheme_source_to_name(code); - if (name) - name = combine_name_with_srcloc(name, code, 1); - } else { - name = rec[drec].value_name; - if (!name || SCHEME_FALSEP(name)) { - name = scheme_source_to_name(code); - if (name) - name = combine_name_with_srcloc(name, code, 1); - } else { - name = combine_name_with_srcloc(name, code, 0); - } - } - return name; -} - -Scheme_Object * -scheme_make_closure_compilation(Scheme_Comp_Env *env, Scheme_Object *code, - Scheme_Compile_Info *rec, int drec) - /* Compiles a `lambda' expression */ -{ - Scheme_Object *allparams, *params, *forms, *param, *name; - Scheme_Closure_Data *data; - Scheme_Compile_Info lam; - Scheme_Comp_Env *frame; - int i; - intptr_t num_params; - Closure_Info *cl; - - data = MALLOC_ONE_TAGGED(Scheme_Closure_Data); - - data->iso.so.type = scheme_compiled_unclosed_procedure_type; - - params = SCHEME_STX_CDR(code); - params = SCHEME_STX_CAR(params); - allparams = params; - - num_params = 0; - for (; SCHEME_STX_PAIRP(params); params = SCHEME_STX_CDR(params)) { - num_params++; - } - SCHEME_CLOSURE_DATA_FLAGS(data) = 0; - if (!SCHEME_STX_NULLP(params)) { - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_REST; - num_params++; - } - data->num_params = num_params; - if ((data->num_params > 0) && scheme_has_method_property(code)) - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_IS_METHOD; - - forms = SCHEME_STX_CDR(code); - forms = SCHEME_STX_CDR(forms); - - frame = scheme_new_compilation_frame(data->num_params, SCHEME_LAMBDA_FRAME, env, rec[drec].certs); - params = allparams; - for (i = 0; i < data->num_params; i++) { - if (!SCHEME_STX_PAIRP(params)) - param = params; - else - param = SCHEME_STX_CAR(params); - scheme_add_compilation_binding(i, param, frame); - if (SCHEME_STX_PAIRP(params)) - params = SCHEME_STX_CDR (params); - } - - if (SCHEME_STX_NULLP(forms)) - scheme_wrong_syntax(NULL, NULL, code, "bad syntax (empty body)"); - - forms = scheme_datum_to_syntax(forms, code, code, 0, 0); - forms = scheme_add_env_renames(forms, frame, env); - - name = scheme_build_closure_name(code, rec, drec); - data->name = name; - - scheme_compile_rec_done_local(rec, drec); - - scheme_init_lambda_rec(rec, drec, &lam, 0); - - { - Scheme_Object *datacode; - datacode = scheme_compile_sequence(forms, - scheme_no_defines(frame), - &lam, 0); - data->code = datacode; - } - - scheme_merge_lambda_rec(rec, drec, &lam, 0); - - cl = MALLOC_ONE_RT(Closure_Info); -#ifdef MZTAG_REQUIRED - cl->type = scheme_rt_closure_info; -#endif - { - int *local_flags; - local_flags = scheme_env_get_flags(frame, 0, data->num_params); - cl->local_flags = local_flags; - } - data->closure_map = (mzshort *)cl; - - return (Scheme_Object *)data; -} - - /*========================================================================*/ /* prompt helpers */ /*========================================================================*/ @@ -9748,257 +8548,6 @@ scheme_default_read_handler(int argc, Scheme_Object *argv[]) return stx; } -/*========================================================================*/ -/* [un]marshalling closure code */ -/*========================================================================*/ - -#define BOOL(x) (x ? scheme_true : scheme_false) - -static Scheme_Object *write_compiled_closure(Scheme_Object *obj) -{ - Scheme_Closure_Data *data; - Scheme_Object *name, *l, *code, *ds, *tl_map; - int svec_size, pos; - Scheme_Marshal_Tables *mt; - - data = (Scheme_Closure_Data *)obj; - - if (data->name) { - name = data->name; - if (SCHEME_VECTORP(name)) { - /* We can only save marshalable src names, which includes - paths, symbols, and strings: */ - Scheme_Object *src; - src = SCHEME_VEC_ELS(name)[1]; - if (!SCHEME_PATHP(src) - && !SCHEME_PATHP(src) - && !SCHEME_SYMBOLP(src)) { - /* Just keep the name */ - name = SCHEME_VEC_ELS(name)[0]; - } - } - } else { - name = scheme_null; - } - - svec_size = data->closure_size; - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - svec_size += ((2 * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT; - } - - if (SCHEME_RPAIRP(data->code)) { - /* This can happen if loaded bytecode is printed out and the procedure - body has never been needed before. - It's also possible in non-JIT mode if an empty closure is embedded - as a 3-D value in compiled code. */ - scheme_delay_load_closure(data); - } - - /* If the body is simple enough, write it directly. - Otherwise, create a delay indirection so that the body - is loaded on demand. */ - code = data->code; - switch (SCHEME_TYPE(code)) { - case scheme_toplevel_type: - case scheme_local_type: - case scheme_local_unbox_type: - case scheme_integer_type: - case scheme_true_type: - case scheme_false_type: - case scheme_void_type: - case scheme_quote_syntax_type: - ds = code; - break; - default: - ds = NULL; - break; - } - - if (!ds) { - mt = scheme_current_thread->current_mt; - if (!mt->pass) { - int key; - - pos = mt->cdata_counter; - if ((!mt->cdata_map || (pos >= 32)) - && !(pos & (pos - 1))) { - /* Need to grow the array */ - Scheme_Object **a; - a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32)); - memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *)); - mt->cdata_map = a; - } - mt->cdata_counter++; - - key = pos & 255; - MZ_OPT_HASH_KEY(&data->iso) = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0x00FF) | (key << 8); - } else { - pos = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0xFF00) >> 8; - - while (pos < mt->cdata_counter) { - ds = mt->cdata_map[pos]; - if (ds) { - ds = SCHEME_PTR_VAL(ds); - if (SAME_OBJ(data->code, ds)) - break; - if (SAME_TYPE(scheme_quote_compilation_type, SCHEME_TYPE(ds))) - if (SAME_OBJ(data->code, SCHEME_PTR_VAL(ds))) - break; - } - pos += 256; - } - if (pos >= mt->cdata_counter) { - scheme_signal_error("didn't find delay record"); - } - } - - ds = mt->cdata_map[pos]; - if (!ds) { - if (mt->pass) - scheme_signal_error("broken closure-data table\n"); - - code = scheme_protect_quote(data->code); - - ds = scheme_alloc_small_object(); - ds->type = scheme_delay_syntax_type; - SCHEME_PTR_VAL(ds) = code; - - MZ_OPT_HASH_KEY(&((Scheme_Small_Object *)ds)->iso) |= 1; /* => hash on ds, not contained data */ - - mt->cdata_map[pos] = ds; - } - } - - /* Encode data->tl_map as either a fixnum or a vector of 16-bit values */ - if (!data->tl_map) - tl_map = scheme_false; - else if ((uintptr_t)data->tl_map & 0x1) { - if (((uintptr_t)data->tl_map & 0xFFFFFFF) == (uintptr_t)data->tl_map) { - /* comfortably a fixnum */ - tl_map = (Scheme_Object *)data->tl_map; - } else { - uintptr_t v; - tl_map = scheme_make_vector(2, NULL); - v = ((uintptr_t)data->tl_map >> 1) & 0x7FFFFFFF; - SCHEME_VEC_ELS(tl_map)[0] = scheme_make_integer(v & 0xFFFF); - SCHEME_VEC_ELS(tl_map)[1] = scheme_make_integer((v >> 16) & 0xFFFF); - } - } else { - int len = ((int *)data->tl_map)[0], i, v; - tl_map = scheme_make_vector(2 * len, NULL); - for (i = 0; i < len; i++) { - v = ((int *)data->tl_map)[i+1]; - SCHEME_VEC_ELS(tl_map)[2*i] = scheme_make_integer(v & 0xFFFF); - SCHEME_VEC_ELS(tl_map)[(2*i)+1] = scheme_make_integer((v >> 16) & 0xFFFF); - } - } - - l = CONS(scheme_make_svector(svec_size, - data->closure_map), - ds); - - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) - l = CONS(scheme_make_integer(data->closure_size), - l); - - return CONS(scheme_make_integer(SCHEME_CLOSURE_DATA_FLAGS(data) & 0x7F), - CONS(scheme_make_integer(data->num_params), - CONS(scheme_make_integer(data->max_let_depth), - CONS(tl_map, - CONS(name, - l))))); -} - -static Scheme_Object *read_compiled_closure(Scheme_Object *obj) -{ - Scheme_Closure_Data *data; - Scheme_Object *v, *tl_map; - -#define BAD_CC "bad compiled closure" -#define X_SCHEME_ASSERT(x, y) - - data = (Scheme_Closure_Data *)scheme_malloc_tagged(sizeof(Scheme_Closure_Data)); - - data->iso.so.type = scheme_unclosed_procedure_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - SCHEME_CLOSURE_DATA_FLAGS(data) = (short)(SCHEME_INT_VAL(v)); - - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - data->num_params = SCHEME_INT_VAL(v); - if (data->num_params < 0) return NULL; - - if (!SCHEME_PAIRP(obj)) return NULL; - data->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); - if (data->max_let_depth < 0) return NULL; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return NULL; - tl_map = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (!SCHEME_FALSEP(tl_map)) { - if (SCHEME_INTP(tl_map)) - data->tl_map = (void *)tl_map; - else if (SCHEME_VECTORP(tl_map)) { - int *n, i, len, v1, v2; - len = SCHEME_VEC_SIZE(tl_map); - if (len & 0x1) - return NULL; - n = (int *)scheme_malloc_atomic(((len/2) + 1) * sizeof(int)); - n[0] = len/2; - for (i = 0; i < len/2; i++) { - v1 = SCHEME_INT_VAL(SCHEME_VEC_ELS(tl_map)[2*i]); - v2 = SCHEME_INT_VAL(SCHEME_VEC_ELS(tl_map)[(2*i) + 1]); - v2 = (v2 << 16) | v1; - n[i+1] = v2; - } - if ((len == 2) && (!(n[1] & 0x80000000))) - data->tl_map = (void *)(intptr_t)((n[1] << 1) | 0x1); - else - data->tl_map = n; - } else - return NULL; - } - - if (!SCHEME_PAIRP(obj)) return NULL; - data->name = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (SCHEME_NULLP(data->name)) - data->name = NULL; - - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - /* v is an svector or an integer... */ - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - if (!SCHEME_INTP(v)) return NULL; - data->closure_size = SCHEME_INT_VAL(v); - - if (!SCHEME_PAIRP(obj)) return NULL; - v = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - } - - data->code = obj; - - if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(v))) return NULL; - - if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS)) - data->closure_size = SCHEME_SVEC_LEN(v); - data->closure_map = SCHEME_SVEC_VEC(v); - - /* If the closure is empty, create the closure now */ - if (!data->closure_size) - return scheme_make_closure(NULL, (Scheme_Object *)data, 0); - else - return (Scheme_Object *)data; -} - /*========================================================================*/ /* precise GC */ /*========================================================================*/ diff --git a/src/racket/src/jitprep.c b/src/racket/src/jitprep.c new file mode 100644 index 0000000000..80773cefcb --- /dev/null +++ b/src/racket/src/jitprep.c @@ -0,0 +1,644 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* This file implements a bytecode pass to insert hook that trigger + JIT compilation. This pass is performed after bytecode is marshaled + or unmarshaled. + + See "eval.c" for an overview of compilation passes and JIT + prepraration. */ + +#include "schpriv.h" +#include "schrunst.h" + +#ifdef MZ_USE_JIT + +static Scheme_Object *jit_application(Scheme_Object *o) +{ + Scheme_Object *orig, *naya = NULL; + Scheme_App_Rec *app, *app2; + int i, n, size; + + app = (Scheme_App_Rec *)o; + n = app->num_args + 1; + + for (i = 0; i < n; i++) { + orig = app->args[i]; + naya = scheme_jit_expr(orig); + if (!SAME_OBJ(orig, naya)) + break; + } + + if (i >= n) + return o; + + size = (sizeof(Scheme_App_Rec) + + ((n - 1) * sizeof(Scheme_Object *)) + + n * sizeof(char)); + app2 = (Scheme_App_Rec *)scheme_malloc_tagged(size); + memcpy(app2, app, size); + app2->args[i] = naya; + + for (i++; i < n; i++) { + orig = app2->args[i]; + naya = scheme_jit_expr(orig); + app2->args[i] = naya; + } + + return (Scheme_Object *)app2; +} + +static Scheme_Object *jit_application2(Scheme_Object *o) +{ + Scheme_App2_Rec *app; + Scheme_Object *nrator, *nrand; + + app = (Scheme_App2_Rec *)o; + + nrator = scheme_jit_expr(app->rator); + nrand = scheme_jit_expr(app->rand); + + if (SAME_OBJ(nrator, app->rator) + && SAME_OBJ(nrand, app->rand)) + return o; + + app = MALLOC_ONE_TAGGED(Scheme_App2_Rec); + memcpy(app, o, sizeof(Scheme_App2_Rec)); + app->rator = nrator; + app->rand = nrand; + + return (Scheme_Object *)app; +} + +static Scheme_Object *jit_application3(Scheme_Object *o) +{ + Scheme_App3_Rec *app; + Scheme_Object *nrator, *nrand1, *nrand2; + + app = (Scheme_App3_Rec *)o; + + nrator = scheme_jit_expr(app->rator); + nrand1 = scheme_jit_expr(app->rand1); + nrand2 = scheme_jit_expr(app->rand2); + + if (SAME_OBJ(nrator, app->rator) + && SAME_OBJ(nrand1, app->rand1) + && SAME_OBJ(nrand2, app->rand2)) + return o; + + app = MALLOC_ONE_TAGGED(Scheme_App3_Rec); + memcpy(app, o, sizeof(Scheme_App3_Rec)); + app->rator = nrator; + app->rand1 = nrand1; + app->rand2 = nrand2; + + return (Scheme_Object *)app; +} + +static Scheme_Object *jit_sequence(Scheme_Object *o) +{ + Scheme_Object *orig, *naya = NULL; + Scheme_Sequence *seq, *seq2; + int i, n, size; + + seq = (Scheme_Sequence *)o; + n = seq->count; + + for (i = 0; i < n; i++) { + orig = seq->array[i]; + naya = scheme_jit_expr(orig); + if (!SAME_OBJ(orig, naya)) + break; + } + + if (i >= n) + return o; + + size = (sizeof(Scheme_Sequence) + + ((n - 1) * sizeof(Scheme_Object *))); + seq2 = (Scheme_Sequence *)scheme_malloc_tagged(size); + memcpy(seq2, seq, size); + seq2->array[i] = naya; + + for (i++; i < n; i++) { + orig = seq2->array[i]; + naya = scheme_jit_expr(orig); + seq2->array[i] = naya; + } + + return (Scheme_Object *)seq2; +} + +static Scheme_Object *jit_branch(Scheme_Object *o) +{ + Scheme_Branch_Rec *b; + Scheme_Object *t, *tb, *fb; + + b = (Scheme_Branch_Rec *)o; + + t = scheme_jit_expr(b->test); + tb = scheme_jit_expr(b->tbranch); + fb = scheme_jit_expr(b->fbranch); + + if (SAME_OBJ(t, b->test) + && SAME_OBJ(tb, b->tbranch) + && SAME_OBJ(fb, b->fbranch)) + return o; + + b = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); + memcpy(b, o, sizeof(Scheme_Branch_Rec)); + b->test = t; + b->tbranch = tb; + b->fbranch = fb; + + return (Scheme_Object *)b; +} + +static Scheme_Object *jit_let_value(Scheme_Object *o) +{ + Scheme_Let_Value *lv = (Scheme_Let_Value *)o; + Scheme_Object *body, *rhs; + + rhs = scheme_jit_expr(lv->value); + body = scheme_jit_expr(lv->body); + + if (SAME_OBJ(rhs, lv->value) + && SAME_OBJ(body, lv->body)) + return o; + + lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); + memcpy(lv, o, sizeof(Scheme_Let_Value)); + lv->value = rhs; + lv->body = body; + + return (Scheme_Object *)lv; +} + +static Scheme_Object *jit_let_one(Scheme_Object *o) +{ + Scheme_Let_One *lo = (Scheme_Let_One *)o; + Scheme_Object *body, *rhs; + + rhs = scheme_jit_expr(lo->value); + body = scheme_jit_expr(lo->body); + + if (SAME_OBJ(rhs, lo->value) + && SAME_OBJ(body, lo->body)) + return o; + + lo = MALLOC_ONE_TAGGED(Scheme_Let_One); + memcpy(lo, o, sizeof(Scheme_Let_One)); + lo->value = rhs; + lo->body = body; + + return (Scheme_Object *)lo; +} + +static Scheme_Object *jit_let_void(Scheme_Object *o) +{ + Scheme_Let_Void *lv = (Scheme_Let_Void *)o; + Scheme_Object *body; + + body = scheme_jit_expr(lv->body); + + if (SAME_OBJ(body, lv->body)) + return o; + + lv = MALLOC_ONE_TAGGED(Scheme_Let_Void); + memcpy(lv, o, sizeof(Scheme_Let_Void)); + lv->body = body; + + return (Scheme_Object *)lv; +} + +static Scheme_Object *jit_letrec(Scheme_Object *o) +{ + Scheme_Letrec *lr = (Scheme_Letrec *)o, *lr2; + Scheme_Object **procs, **procs2, *v; + int i, count; + + count = lr->count; + + lr2 = MALLOC_ONE_TAGGED(Scheme_Letrec); + memcpy(lr2, lr, sizeof(Scheme_Letrec)); + + procs = lr->procs; + procs2 = MALLOC_N(Scheme_Object *, count); + lr2->procs = procs2; + + for (i = 0; i < count; i++) { + v = scheme_jit_closure(procs[i], (Scheme_Object *)lr2); + procs2[i] = v; + } + + v = scheme_jit_expr(lr->body); + lr2->body = v; + + return (Scheme_Object *)lr2; +} + +static Scheme_Object *jit_wcm(Scheme_Object *o) +{ + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; + Scheme_Object *k, *v, *b; + + k = scheme_jit_expr(wcm->key); + v = scheme_jit_expr(wcm->val); + b = scheme_jit_expr(wcm->body); + if (SAME_OBJ(wcm->key, k) + && SAME_OBJ(wcm->val, v) + && SAME_OBJ(wcm->body, b)) + return o; + + wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + memcpy(wcm, o, sizeof(Scheme_With_Continuation_Mark)); + + wcm->key = k; + wcm->val = v; + wcm->body = b; + + return (Scheme_Object *)wcm; +} + +/*========================================================================*/ +/* other syntax */ +/*========================================================================*/ + +static Scheme_Object *define_values_jit(Scheme_Object *data) +{ + Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya; + + if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type) + && (SCHEME_VEC_SIZE(data) == 2)) + naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]); + else + naya = scheme_jit_expr(orig); + + if (SAME_OBJ(naya, orig)) + return data; + else { + orig = naya; + naya = scheme_clone_vector(data, 0, 1); + SCHEME_VEC_ELS(naya)[0] = orig; + return naya; + } +} + +static Scheme_Object *set_jit(Scheme_Object *data) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data, *naya; + Scheme_Object *orig_val, *naya_val; + + orig_val = sb->val; + + naya_val = scheme_jit_expr(orig_val); + + if (SAME_OBJ(naya_val, orig_val)) + return data; + else { + naya = MALLOC_ONE_TAGGED(Scheme_Set_Bang); + memcpy(naya, sb, sizeof(Scheme_Set_Bang)); + naya->val = naya_val; + return (Scheme_Object *)naya; + } +} + +static Scheme_Object *ref_jit(Scheme_Object *data) +{ + return data; +} + +static Scheme_Object *apply_values_jit(Scheme_Object *data) +{ + Scheme_Object *f, *e; + + f = scheme_jit_expr(SCHEME_PTR1_VAL(data)); + e = scheme_jit_expr(SCHEME_PTR2_VAL(data)); + + if (SAME_OBJ(f, SCHEME_PTR1_VAL(data)) + && SAME_OBJ(e, SCHEME_PTR2_VAL(data))) + return data; + else { + data = scheme_alloc_object(); + data->type = scheme_apply_values_type; + SCHEME_PTR1_VAL(data) = f; + SCHEME_PTR2_VAL(data) = e; + return data; + } +} + +Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr) +{ +#ifdef MZ_USE_JIT + Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr; + + if (!seqin->native_code) { + Scheme_Case_Lambda *seqout; + Scheme_Native_Closure_Data *ndata; + Scheme_Object *val, *name; + int i, cnt, size, all_closed = 1; + + cnt = seqin->count; + + size = sizeof(Scheme_Case_Lambda) + ((cnt - 1) * sizeof(Scheme_Object *)); + + seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size); + memcpy(seqout, seqin, size); + + name = seqin->name; + if (name && SCHEME_BOXP(name)) + name = SCHEME_BOX_VAL(name); + + for (i = 0; i < cnt; i++) { + val = seqout->array[i]; + if (SCHEME_PROCP(val)) { + /* Undo creation of empty closure */ + val = (Scheme_Object *)((Scheme_Closure *)val)->code; + seqout->array[i] = val; + } + ((Scheme_Closure_Data *)val)->name = name; + if (((Scheme_Closure_Data *)val)->closure_size) + all_closed = 0; + } + + /* Generating the code may cause empty closures to be formed: */ + ndata = scheme_generate_case_lambda(seqout); + seqout->native_code = ndata; + + if (all_closed) { + /* Native closures do not refer back to the original bytecode, + so no need to worry about clearing the reference. */ + Scheme_Native_Closure *nc; + nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata); + for (i = 0; i < cnt; i++) { + val = seqout->array[i]; + if (!SCHEME_PROCP(val)) { + val = scheme_make_native_closure(((Scheme_Closure_Data *)val)->u.native_code); + } + nc->vals[i] = val; + } + return (Scheme_Object *)nc; + } else { + /* The case-lambda data must point to the original closure-data + record, because that's where the closure maps are kept. But + we don't need the bytecode, anymore. So clone the + closure-data record and drop the bytecode in thte clone. */ + for (i = 0; i < cnt; i++) { + val = seqout->array[i]; + if (!SCHEME_PROCP(val)) { + Scheme_Closure_Data *data; + data = MALLOC_ONE_TAGGED(Scheme_Closure_Data); + memcpy(data, val, sizeof(Scheme_Closure_Data)); + data->code = NULL; + seqout->array[i] = (Scheme_Object *)data; + } + } + } + + return (Scheme_Object *)seqout; + } +#endif + + return expr; +} + +static Scheme_Object *bangboxenv_jit(Scheme_Object *data) +{ + Scheme_Object *orig, *naya, *new_data; + + orig = SCHEME_PTR2_VAL(data); + naya = scheme_jit_expr(orig); + if (SAME_OBJ(naya, orig)) + return data; + else { + new_data = scheme_alloc_object(); + new_data->type = scheme_boxenv_type; + SCHEME_PTR1_VAL(new_data) = SCHEME_PTR1_VAL(data); + SCHEME_PTR2_VAL(new_data) = naya; + return new_data; + } +} + +static Scheme_Object *begin0_jit(Scheme_Object *data) +{ + Scheme_Sequence *seq = (Scheme_Sequence *)data, *seq2; + Scheme_Object *old, *naya = NULL; + int i, j, count; + + count = seq->count; + for (i = 0; i < count; i++) { + old = seq->array[i]; + naya = scheme_jit_expr(old); + if (!SAME_OBJ(old, naya)) + break; + } + + if (i >= count) + return data; + + seq2 = (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence) + + (count - 1) + * sizeof(Scheme_Object *)); + seq2->so.type = scheme_begin0_sequence_type; + seq2->count = count; + for (j = 0; j < i; j++) { + seq2->array[j] = seq->array[j]; + } + seq2->array[i] = naya; + for (i++; i < count; i++) { + old = seq->array[i]; + naya = scheme_jit_expr(old); + seq2->array[i] = naya; + } + + return (Scheme_Object *)seq2; +} + +static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr, int jit) +{ + Resolve_Prefix *rp, *orig_rp; + Scheme_Object *naya, *rhs; + + rhs = SCHEME_VEC_ELS(expr)[0]; + if (jit) + naya = scheme_jit_expr(rhs); + else + naya = rhs; + + orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1]; + rp = scheme_prefix_eval_clone(orig_rp); + + if (SAME_OBJ(naya, rhs) + && SAME_OBJ(orig_rp, rp)) + return expr; + else { + expr = scheme_clone_vector(expr, 0, 1); + SCHEME_VEC_ELS(expr)[0] = naya; + SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp; + return expr; + } +} + +static Scheme_Object *define_syntaxes_jit(Scheme_Object *expr) +{ + return do_define_syntaxes_jit(expr, 1); +} + +static Scheme_Object *define_for_syntaxes_jit(Scheme_Object *expr) +{ + return do_define_syntaxes_jit(expr, 1); +} + +Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *expr) +{ + return do_define_syntaxes_jit(expr, 0); +} + +/*========================================================================*/ +/* closures */ +/*========================================================================*/ + +Scheme_Object *scheme_jit_closure(Scheme_Object *code, Scheme_Object *context) + /* If lr is supplied as a letrec binding this closure, it may be used + for JIT compilation. */ +{ +#ifdef MZ_USE_JIT + Scheme_Closure_Data *data = (Scheme_Closure_Data *)code, *data2; + + /* We need to cache clones to support multiple references + to a zero-sized closure in bytecode. We need either a clone + or native code, and context determines which field is relevant, + so we put the two possibilities in a union `u'. */ + + if (!context) + data2 = data->u.jit_clone; + else + data2 = NULL; + + if (!data2) { + Scheme_Native_Closure_Data *ndata; + + data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data); + memcpy(data2, code, sizeof(Scheme_Closure_Data)); + + data2->context = context; + + ndata = scheme_generate_lambda(data2, 1, NULL); + data2->u.native_code = ndata; + + if (!context) + data->u.jit_clone = data2; + } + + /* If it's zero-sized, then create closure now */ + if (!data2->closure_size) + return scheme_make_native_closure(data2->u.native_code); + + return (Scheme_Object *)data2; +#endif + + return code; +} + +/*========================================================================*/ +/* expressions */ +/*========================================================================*/ + +Scheme_Object *scheme_jit_expr(Scheme_Object *expr) +{ + Scheme_Type type = SCHEME_TYPE(expr); + + switch (type) { + case scheme_application_type: + return jit_application(expr); + case scheme_application2_type: + return jit_application2(expr); + case scheme_application3_type: + return jit_application3(expr); + case scheme_sequence_type: + case scheme_splice_sequence_type: + return jit_sequence(expr); + case scheme_branch_type: + return jit_branch(expr); + case scheme_with_cont_mark_type: + return jit_wcm(expr); + case scheme_unclosed_procedure_type: + return scheme_jit_closure(expr, NULL); + case scheme_let_value_type: + return jit_let_value(expr); + case scheme_let_void_type: + return jit_let_void(expr); + case scheme_letrec_type: + return jit_letrec(expr); + case scheme_let_one_type: + return jit_let_one(expr); + case scheme_closure_type: + { + Scheme_Closure *c = (Scheme_Closure *)expr; + if (ZERO_SIZED_CLOSUREP(c)) { + /* JIT the closure body, producing a native closure: */ + return scheme_jit_closure((Scheme_Object *)c->code, NULL); + } else + return expr; + } + case scheme_case_closure_type: + { + return scheme_unclose_case_lambda(expr, 1); + } + case scheme_define_values_type: + return define_values_jit(expr); + case scheme_define_syntaxes_type: + return define_syntaxes_jit(expr); + case scheme_define_for_syntax_type: + return define_for_syntaxes_jit(expr); + case scheme_set_bang_type: + return set_jit(expr); + case scheme_boxenv_type: + return bangboxenv_jit(expr); + case scheme_begin0_sequence_type: + return begin0_jit(expr); + case scheme_require_form_type: + return scheme_top_level_require_jit(expr); + case scheme_varref_form_type: + return ref_jit(expr); + case scheme_apply_values_type: + return apply_values_jit(expr); + case scheme_case_lambda_sequence_type: + return scheme_case_lambda_jit(expr); + case scheme_module_type: + return scheme_module_jit(expr); + default: + return expr; + } +} + +#else + +Scheme_Object *scheme_jit_expr(Scheme_Object *expr) +{ + return expr; +} + +#endif diff --git a/src/racket/src/marshal.c b/src/racket/src/marshal.c new file mode 100644 index 0000000000..b22981ce50 --- /dev/null +++ b/src/racket/src/marshal.c @@ -0,0 +1,1716 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" + +#define cons(a,b) scheme_make_pair(a,b) +#define CONS(a,b) scheme_make_pair(a,b) + +static Scheme_Object *write_let_value(Scheme_Object *obj); +static Scheme_Object *read_let_value(Scheme_Object *obj); +static Scheme_Object *write_let_void(Scheme_Object *obj); +static Scheme_Object *read_let_void(Scheme_Object *obj); +static Scheme_Object *write_letrec(Scheme_Object *obj); +static Scheme_Object *read_letrec(Scheme_Object *obj); +static Scheme_Object *write_let_one(Scheme_Object *obj); +static Scheme_Object *read_let_one(Scheme_Object *obj); +static Scheme_Object *write_top(Scheme_Object *obj); +static Scheme_Object *read_top(Scheme_Object *obj); +static Scheme_Object *write_case_lambda(Scheme_Object *obj); +static Scheme_Object *read_case_lambda(Scheme_Object *obj); + +static Scheme_Object *read_define_values(Scheme_Object *obj); +static Scheme_Object *write_define_values(Scheme_Object *obj); +static Scheme_Object *read_define_syntaxes(Scheme_Object *obj); +static Scheme_Object *write_define_syntaxes(Scheme_Object *obj); +static Scheme_Object *read_define_for_syntax(Scheme_Object *obj); +static Scheme_Object *write_define_for_syntax(Scheme_Object *obj); +static Scheme_Object *read_set_bang(Scheme_Object *obj); +static Scheme_Object *write_set_bang(Scheme_Object *obj); +static Scheme_Object *read_boxenv(Scheme_Object *obj); +static Scheme_Object *write_boxenv(Scheme_Object *obj); +static Scheme_Object *read_varref(Scheme_Object *obj); +static Scheme_Object *write_varref(Scheme_Object *obj); +static Scheme_Object *read_apply_values(Scheme_Object *obj); +static Scheme_Object *write_apply_values(Scheme_Object *obj); + +static Scheme_Object *write_application(Scheme_Object *obj); +static Scheme_Object *read_application(Scheme_Object *obj); +static Scheme_Object *write_sequence(Scheme_Object *obj); +static Scheme_Object *read_sequence(Scheme_Object *obj); +static Scheme_Object *read_sequence_save_first(Scheme_Object *obj); +static Scheme_Object *read_sequence_splice(Scheme_Object *obj); +static Scheme_Object *write_branch(Scheme_Object *obj); +static Scheme_Object *read_branch(Scheme_Object *obj); +static Scheme_Object *write_with_cont_mark(Scheme_Object *obj); +static Scheme_Object *read_with_cont_mark(Scheme_Object *obj); +static Scheme_Object *write_quote_syntax(Scheme_Object *obj); +static Scheme_Object *read_quote_syntax(Scheme_Object *obj); + +static Scheme_Object *write_toplevel(Scheme_Object *obj); +static Scheme_Object *read_toplevel(Scheme_Object *obj); +static Scheme_Object *write_variable(Scheme_Object *obj); +static Scheme_Object *read_variable(Scheme_Object *obj); +static Scheme_Object *write_module_variable(Scheme_Object *obj); +static Scheme_Object *read_module_variable(Scheme_Object *obj); +static Scheme_Object *write_local(Scheme_Object *obj); +static Scheme_Object *read_local(Scheme_Object *obj); +static Scheme_Object *read_local_unbox(Scheme_Object *obj); +static Scheme_Object *write_resolve_prefix(Scheme_Object *obj); +static Scheme_Object *read_resolve_prefix(Scheme_Object *obj, Scheme_Object *insp); + +static Scheme_Object *write_compiled_closure(Scheme_Object *obj); +static Scheme_Object *read_compiled_closure(Scheme_Object *obj); + +static Scheme_Object *write_module(Scheme_Object *obj); +static Scheme_Object *read_module(Scheme_Object *obj); +static Scheme_Object *read_top_level_require(Scheme_Object *obj); +static Scheme_Object *write_top_level_require(Scheme_Object *obj); + +void scheme_init_marshal(Scheme_Env *env) +{ + scheme_install_type_writer(scheme_application_type, write_application); + scheme_install_type_reader(scheme_application_type, read_application); + scheme_install_type_writer(scheme_application2_type, write_application); + scheme_install_type_reader(scheme_application2_type, read_application); + scheme_install_type_writer(scheme_application3_type, write_application); + scheme_install_type_reader(scheme_application3_type, read_application); + scheme_install_type_writer(scheme_sequence_type, write_sequence); + scheme_install_type_reader(scheme_sequence_type, read_sequence); + scheme_install_type_writer(scheme_branch_type, write_branch); + scheme_install_type_reader(scheme_branch_type, read_branch); + scheme_install_type_writer(scheme_with_cont_mark_type, write_with_cont_mark); + scheme_install_type_reader(scheme_with_cont_mark_type, read_with_cont_mark); + scheme_install_type_writer(scheme_quote_syntax_type, write_quote_syntax); + scheme_install_type_reader(scheme_quote_syntax_type, read_quote_syntax); + scheme_install_type_writer(scheme_begin0_sequence_type, write_sequence); + scheme_install_type_reader(scheme_begin0_sequence_type, read_sequence_save_first); + scheme_install_type_writer(scheme_splice_sequence_type, write_sequence); + scheme_install_type_reader(scheme_splice_sequence_type, read_sequence_splice); + + scheme_install_type_writer(scheme_let_value_type, write_let_value); + scheme_install_type_reader(scheme_let_value_type, read_let_value); + scheme_install_type_writer(scheme_let_void_type, write_let_void); + scheme_install_type_reader(scheme_let_void_type, read_let_void); + scheme_install_type_writer(scheme_letrec_type, write_letrec); + scheme_install_type_reader(scheme_letrec_type, read_letrec); + scheme_install_type_writer(scheme_let_one_type, write_let_one); + scheme_install_type_reader(scheme_let_one_type, read_let_one); + scheme_install_type_writer(scheme_case_lambda_sequence_type, write_case_lambda); + scheme_install_type_reader(scheme_case_lambda_sequence_type, read_case_lambda); + + scheme_install_type_writer(scheme_define_values_type, write_define_values); + scheme_install_type_reader(scheme_define_values_type, read_define_values); + scheme_install_type_writer(scheme_define_syntaxes_type, write_define_syntaxes); + scheme_install_type_reader(scheme_define_syntaxes_type, read_define_syntaxes); + scheme_install_type_writer(scheme_define_for_syntax_type, write_define_for_syntax); + scheme_install_type_reader(scheme_define_for_syntax_type, read_define_for_syntax); + scheme_install_type_writer(scheme_set_bang_type, write_set_bang); + scheme_install_type_reader(scheme_set_bang_type, read_set_bang); + scheme_install_type_writer(scheme_boxenv_type, write_boxenv); + scheme_install_type_reader(scheme_boxenv_type, read_boxenv); + scheme_install_type_writer(scheme_varref_form_type, write_varref); + scheme_install_type_reader(scheme_varref_form_type, read_varref); + scheme_install_type_writer(scheme_apply_values_type, write_apply_values); + scheme_install_type_reader(scheme_apply_values_type, read_apply_values); + + scheme_install_type_writer(scheme_compilation_top_type, write_top); + scheme_install_type_reader(scheme_compilation_top_type, read_top); + + scheme_install_type_writer(scheme_unclosed_procedure_type, + write_compiled_closure); + scheme_install_type_reader(scheme_unclosed_procedure_type, + read_compiled_closure); + + scheme_install_type_writer(scheme_toplevel_type, write_toplevel); + scheme_install_type_reader(scheme_toplevel_type, read_toplevel); + scheme_install_type_writer(scheme_variable_type, write_variable); + scheme_install_type_reader(scheme_variable_type, read_variable); + scheme_install_type_writer(scheme_module_variable_type, write_module_variable); + scheme_install_type_reader(scheme_module_variable_type, read_module_variable); + scheme_install_type_writer(scheme_local_type, write_local); + scheme_install_type_reader(scheme_local_type, read_local); + scheme_install_type_writer(scheme_local_unbox_type, write_local); + scheme_install_type_reader(scheme_local_unbox_type, read_local_unbox); + scheme_install_type_writer(scheme_resolve_prefix_type, write_resolve_prefix); + scheme_install_type_reader2(scheme_resolve_prefix_type, read_resolve_prefix); + + scheme_install_type_writer(scheme_module_type, write_module); + scheme_install_type_reader(scheme_module_type, read_module); + scheme_install_type_writer(scheme_require_form_type, write_top_level_require); + scheme_install_type_reader(scheme_require_form_type, read_top_level_require); +} + + +static Scheme_Object *write_let_value(Scheme_Object *obj) +{ + Scheme_Let_Value *lv; + + lv = (Scheme_Let_Value *)obj; + + return cons(scheme_make_integer(lv->count), + cons(scheme_make_integer(lv->position), + cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false, + cons(scheme_protect_quote(lv->value), + scheme_protect_quote(lv->body))))); +} + +static Scheme_Object *read_let_value(Scheme_Object *obj) +{ + Scheme_Let_Value *lv; + + lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value)); + lv->iso.so.type = scheme_let_value_type; + + if (!SCHEME_PAIRP(obj)) return NULL; + lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + lv->position = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + lv->value = SCHEME_CAR(obj); + lv->body = SCHEME_CDR(obj); + + return (Scheme_Object *)lv; +} + +static Scheme_Object *write_let_void(Scheme_Object *obj) +{ + Scheme_Let_Void *lv; + + lv = (Scheme_Let_Void *)obj; + + return cons(scheme_make_integer(lv->count), + cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false, + scheme_protect_quote(lv->body))); +} + +static Scheme_Object *read_let_void(Scheme_Object *obj) +{ + Scheme_Let_Void *lv; + + lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void)); + lv->iso.so.type = scheme_let_void_type; + + if (!SCHEME_PAIRP(obj)) return NULL; + lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); + lv->body = SCHEME_CDR(obj); + + return (Scheme_Object *)lv; +} + +static Scheme_Object *write_let_one(Scheme_Object *obj) +{ + scheme_signal_error("let-one writer shouldn't be used"); + return NULL; +} + +static Scheme_Object *read_let_one(Scheme_Object *obj) +{ + return NULL; +} + +static Scheme_Object *write_letrec(Scheme_Object *obj) +{ + Scheme_Letrec *lr = (Scheme_Letrec *)obj; + Scheme_Object *l = scheme_null; + int i = lr->count; + + while (i--) { + l = cons(scheme_protect_quote(lr->procs[i]), l); + } + + return cons(scheme_make_integer(lr->count), + cons(scheme_protect_quote(lr->body), l)); +} + +static Scheme_Object *read_letrec(Scheme_Object *obj) +{ + Scheme_Letrec *lr; + int i, c; + Scheme_Object **sa; + + lr = MALLOC_ONE_TAGGED(Scheme_Letrec); + + lr->so.type = scheme_letrec_type; + + if (!SCHEME_PAIRP(obj)) return NULL; + c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return NULL; + lr->body = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + sa = MALLOC_N(Scheme_Object*, c); + lr->procs = sa; + for (i = 0; i < c; i++) { + if (!SCHEME_PAIRP(obj)) return NULL; + lr->procs[i] = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + } + + return (Scheme_Object *)lr; +} + +static Scheme_Object *write_top(Scheme_Object *obj) +{ + Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj; + + if (!top->prefix) + scheme_raise_exn(MZEXN_FAIL, + "write: cannot marshal shared compiled code: %V", + obj); + + return cons(scheme_make_integer(top->max_let_depth), + cons((Scheme_Object *)top->prefix, + scheme_protect_quote(top->code))); +} + +static Scheme_Object *read_top(Scheme_Object *obj) +{ + Scheme_Compilation_Top *top; + + top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); + top->so.type = scheme_compilation_top_type; + if (!SCHEME_PAIRP(obj)) return NULL; + top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); + top->code = SCHEME_CDR(obj); + + return (Scheme_Object *)top; +} + +static Scheme_Object *write_case_lambda(Scheme_Object *obj) +{ + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)obj; + int i; + Scheme_Object *l; + + i = cl->count; + + l = scheme_null; + for (; i--; ) { + l = cons(cl->array[i], l); + } + + return cons((cl->name ? cl->name : scheme_null), + l); +} + +static Scheme_Object *read_case_lambda(Scheme_Object *obj) +{ + Scheme_Object *s, *a; + int count, i, all_closed = 1; + Scheme_Case_Lambda *cl; + + if (!SCHEME_PAIRP(obj)) return NULL; + s = SCHEME_CDR(obj); + for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) { + count++; + } + + cl = (Scheme_Case_Lambda *) + scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) + + (count - 1) * sizeof(Scheme_Object *)); + + cl->so.type = scheme_case_lambda_sequence_type; + cl->count = count; + cl->name = SCHEME_CAR(obj); + if (SCHEME_NULLP(cl->name)) + cl->name = NULL; + + s = SCHEME_CDR(obj); + for (i = 0; i < count; i++, s = SCHEME_CDR(s)) { + a = SCHEME_CAR(s); + cl->array[i] = a; + if (!SCHEME_PROCP(a)) { + if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type)) + return NULL; + all_closed = 0; + } + } + + if (all_closed) { + /* Empty closure: produce procedure value directly. + (We assume that this was generated by a direct write of + a case-lambda data record in print.c, and that it's not + in a CASE_LAMBDA_EXPD syntax record.) */ + return scheme_case_lambda_execute((Scheme_Object *)cl); + } + + return (Scheme_Object *)cl; +} + +static Scheme_Object *read_define_values(Scheme_Object *obj) +{ + if (!SCHEME_VECTORP(obj)) return NULL; + + obj = scheme_clone_vector(obj, 0, 0); + obj->type = scheme_define_values_type; + return obj; +} + +static Scheme_Object *write_define_values(Scheme_Object *obj) +{ + Scheme_Object *e; + + obj = scheme_clone_vector(obj, 0, 0); + e = scheme_protect_quote(SCHEME_VEC_ELS(obj)[0]); + SCHEME_VEC_ELS(obj)[0] = e; + + return obj; +} + +static Scheme_Object *read_define_syntaxes(Scheme_Object *obj) +{ + if (!SCHEME_VECTORP(obj)) return NULL; + + obj = scheme_clone_vector(obj, 0, 0); + obj->type = scheme_define_syntaxes_type; + return obj; +} + +static Scheme_Object *write_define_syntaxes(Scheme_Object *obj) +{ + return write_define_values(obj); +} + +static Scheme_Object *read_define_for_syntax(Scheme_Object *obj) +{ + if (!SCHEME_VECTORP(obj)) return NULL; + + obj = scheme_clone_vector(obj, 0, 0); + obj->type = scheme_define_for_syntax_type; + return obj; +} + +static Scheme_Object *write_define_for_syntax(Scheme_Object *obj) +{ + return write_define_values(obj); +} + +static Scheme_Object *read_set_bang(Scheme_Object *obj) +{ + Scheme_Set_Bang *sb; + + sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); + sb->so.type = scheme_set_bang_type; + + if (!SCHEME_PAIRP(obj)) return NULL; + sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj)); + + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + + sb->var = SCHEME_CAR(obj); + sb->val = SCHEME_CDR(obj); + + return (Scheme_Object *)sb; +} + +static Scheme_Object *write_set_bang(Scheme_Object *obj) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj; + return scheme_make_pair((sb->set_undef ? scheme_true : scheme_false), + scheme_make_pair(sb->var, + scheme_protect_quote(sb->val))); +} + +Scheme_Object *write_varref(Scheme_Object *o) +{ + return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); +} + +Scheme_Object *read_varref(Scheme_Object *o) +{ + Scheme_Object *data; + + if (!SCHEME_PAIRP(o)) return NULL; + + data = scheme_alloc_object(); + data->type = scheme_varref_form_type; + SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); + SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); + + return data; +} + +Scheme_Object *write_apply_values(Scheme_Object *o) +{ + return scheme_make_pair(scheme_protect_quote(SCHEME_PTR1_VAL(o)), + scheme_protect_quote(SCHEME_PTR2_VAL(o))); +} + +Scheme_Object *read_apply_values(Scheme_Object *o) +{ + Scheme_Object *data; + + if (!SCHEME_PAIRP(o)) return NULL; + + data = scheme_alloc_object(); + data->type = scheme_apply_values_type; + SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); + SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); + + return data; +} + +Scheme_Object *write_boxenv(Scheme_Object *o) +{ + return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); +} + +Scheme_Object *read_boxenv(Scheme_Object *o) +{ + Scheme_Object *data; + + if (!SCHEME_PAIRP(o)) return NULL; + + data = scheme_alloc_object(); + data->type = scheme_boxenv_type; + SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); + SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); + + return data; +} + +#define BOOL(x) (x ? scheme_true : scheme_false) + +static Scheme_Object *write_application(Scheme_Object *obj) +{ + scheme_signal_error("app writer shouldn't be used"); + return NULL; +} + +static Scheme_Object *read_application(Scheme_Object *obj) +{ + return NULL; +} + +static Scheme_Object *write_sequence(Scheme_Object *obj) +{ + Scheme_Object *l; + int i; + + i = ((Scheme_Sequence *)obj)->count; + + l = scheme_null; + for (; i--; ) { + l = cons(scheme_protect_quote(((Scheme_Sequence *)obj)->array[i]), l); + } + + return l; +} + +static Scheme_Object *read_sequence(Scheme_Object *obj) +{ + return scheme_make_sequence_compilation(obj, 1); +} + +static Scheme_Object *read_sequence_save_first(Scheme_Object *obj) +{ + return scheme_make_sequence_compilation(obj, -2); +} + +static Scheme_Object *read_sequence_splice(Scheme_Object *obj) +{ + obj = scheme_make_sequence_compilation(obj, 1); + if (SAME_TYPE(SCHEME_TYPE(obj), scheme_sequence_type)) + obj->type = scheme_splice_sequence_type; + return obj; +} + +static Scheme_Object *write_branch(Scheme_Object *obj) +{ + scheme_signal_error("branch writer shouldn't be used"); + return NULL; +} + +static Scheme_Object *read_branch(Scheme_Object *obj) +{ + return NULL; +} + +static Scheme_Object *write_with_cont_mark(Scheme_Object *obj) +{ + Scheme_With_Continuation_Mark *wcm; + + wcm = (Scheme_With_Continuation_Mark *)obj; + + return cons(scheme_protect_quote(wcm->key), + cons(scheme_protect_quote(wcm->val), + scheme_protect_quote(wcm->body))); +} + +static Scheme_Object *read_with_cont_mark(Scheme_Object *obj) +{ + Scheme_With_Continuation_Mark *wcm; + + if (!SCHEME_PAIRP(obj) || !SCHEME_PAIRP(SCHEME_CDR(obj))) + return NULL; /* bad .zo */ + + wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + wcm->so.type = scheme_with_cont_mark_type; + wcm->key = SCHEME_CAR(obj); + wcm->val = SCHEME_CADR(obj); + wcm->body = SCHEME_CDR(SCHEME_CDR(obj)); + + return (Scheme_Object *)wcm; +} + +static Scheme_Object *write_quote_syntax(Scheme_Object *obj) +{ + Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)obj; + + return cons(scheme_make_integer(qs->depth), + cons(scheme_make_integer(qs->position), + scheme_make_integer(qs->midpoint))); +} + +static Scheme_Object *read_quote_syntax(Scheme_Object *obj) +{ + Scheme_Quote_Syntax *qs; + Scheme_Object *a; + int c, i, p; + + if (!SCHEME_PAIRP(obj)) return NULL; + + a = SCHEME_CAR(obj); + c = SCHEME_INT_VAL(a); + + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + + a = SCHEME_CAR(obj); + i = SCHEME_INT_VAL(a); + + a = SCHEME_CDR(obj); + p = SCHEME_INT_VAL(a); + + qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); + qs->so.type = scheme_quote_syntax_type; + qs->depth = c; + qs->position = i; + qs->midpoint = p; + + return (Scheme_Object *)qs; +} + +#define BOOL(x) (x ? scheme_true : scheme_false) + +static Scheme_Object *write_compiled_closure(Scheme_Object *obj) +{ + Scheme_Closure_Data *data; + Scheme_Object *name, *l, *code, *ds, *tl_map; + int svec_size, pos; + Scheme_Marshal_Tables *mt; + + data = (Scheme_Closure_Data *)obj; + + if (data->name) { + name = data->name; + if (SCHEME_VECTORP(name)) { + /* We can only save marshalable src names, which includes + paths, symbols, and strings: */ + Scheme_Object *src; + src = SCHEME_VEC_ELS(name)[1]; + if (!SCHEME_PATHP(src) + && !SCHEME_PATHP(src) + && !SCHEME_SYMBOLP(src)) { + /* Just keep the name */ + name = SCHEME_VEC_ELS(name)[0]; + } + } + } else { + name = scheme_null; + } + + svec_size = data->closure_size; + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + svec_size += ((2 * (data->num_params + data->closure_size)) + BITS_PER_MZSHORT - 1) / BITS_PER_MZSHORT; + } + + if (SCHEME_RPAIRP(data->code)) { + /* This can happen if loaded bytecode is printed out and the procedure + body has never been needed before. + It's also possible in non-JIT mode if an empty closure is embedded + as a 3-D value in compiled code. */ + scheme_delay_load_closure(data); + } + + /* If the body is simple enough, write it directly. + Otherwise, create a delay indirection so that the body + is loaded on demand. */ + code = data->code; + switch (SCHEME_TYPE(code)) { + case scheme_toplevel_type: + case scheme_local_type: + case scheme_local_unbox_type: + case scheme_integer_type: + case scheme_true_type: + case scheme_false_type: + case scheme_void_type: + case scheme_quote_syntax_type: + ds = code; + break; + default: + ds = NULL; + break; + } + + if (!ds) { + mt = scheme_current_thread->current_mt; + if (!mt->pass) { + int key; + + pos = mt->cdata_counter; + if ((!mt->cdata_map || (pos >= 32)) + && !(pos & (pos - 1))) { + /* Need to grow the array */ + Scheme_Object **a; + a = MALLOC_N(Scheme_Object *, (pos ? 2 * pos : 32)); + memcpy(a, mt->cdata_map, pos * sizeof(Scheme_Object *)); + mt->cdata_map = a; + } + mt->cdata_counter++; + + key = pos & 255; + MZ_OPT_HASH_KEY(&data->iso) = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0x00FF) | (key << 8); + } else { + pos = ((int)MZ_OPT_HASH_KEY(&data->iso) & 0xFF00) >> 8; + + while (pos < mt->cdata_counter) { + ds = mt->cdata_map[pos]; + if (ds) { + ds = SCHEME_PTR_VAL(ds); + if (SAME_OBJ(data->code, ds)) + break; + if (SAME_TYPE(scheme_quote_compilation_type, SCHEME_TYPE(ds))) + if (SAME_OBJ(data->code, SCHEME_PTR_VAL(ds))) + break; + } + pos += 256; + } + if (pos >= mt->cdata_counter) { + scheme_signal_error("didn't find delay record"); + } + } + + ds = mt->cdata_map[pos]; + if (!ds) { + if (mt->pass) + scheme_signal_error("broken closure-data table\n"); + + code = scheme_protect_quote(data->code); + + ds = scheme_alloc_small_object(); + ds->type = scheme_delay_syntax_type; + SCHEME_PTR_VAL(ds) = code; + + MZ_OPT_HASH_KEY(&((Scheme_Small_Object *)ds)->iso) |= 1; /* => hash on ds, not contained data */ + + mt->cdata_map[pos] = ds; + } + } + + /* Encode data->tl_map as either a fixnum or a vector of 16-bit values */ + if (!data->tl_map) + tl_map = scheme_false; + else if ((uintptr_t)data->tl_map & 0x1) { + if (((uintptr_t)data->tl_map & 0xFFFFFFF) == (uintptr_t)data->tl_map) { + /* comfortably a fixnum */ + tl_map = (Scheme_Object *)data->tl_map; + } else { + uintptr_t v; + tl_map = scheme_make_vector(2, NULL); + v = ((uintptr_t)data->tl_map >> 1) & 0x7FFFFFFF; + SCHEME_VEC_ELS(tl_map)[0] = scheme_make_integer(v & 0xFFFF); + SCHEME_VEC_ELS(tl_map)[1] = scheme_make_integer((v >> 16) & 0xFFFF); + } + } else { + int len = ((int *)data->tl_map)[0], i, v; + tl_map = scheme_make_vector(2 * len, NULL); + for (i = 0; i < len; i++) { + v = ((int *)data->tl_map)[i+1]; + SCHEME_VEC_ELS(tl_map)[2*i] = scheme_make_integer(v & 0xFFFF); + SCHEME_VEC_ELS(tl_map)[(2*i)+1] = scheme_make_integer((v >> 16) & 0xFFFF); + } + } + + l = CONS(scheme_make_svector(svec_size, + data->closure_map), + ds); + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) + l = CONS(scheme_make_integer(data->closure_size), + l); + + return CONS(scheme_make_integer(SCHEME_CLOSURE_DATA_FLAGS(data) & 0x7F), + CONS(scheme_make_integer(data->num_params), + CONS(scheme_make_integer(data->max_let_depth), + CONS(tl_map, + CONS(name, + l))))); +} + +static Scheme_Object *read_compiled_closure(Scheme_Object *obj) +{ + Scheme_Closure_Data *data; + Scheme_Object *v, *tl_map; + +#define BAD_CC "bad compiled closure" +#define X_SCHEME_ASSERT(x, y) + + data = (Scheme_Closure_Data *)scheme_malloc_tagged(sizeof(Scheme_Closure_Data)); + + data->iso.so.type = scheme_unclosed_procedure_type; + + if (!SCHEME_PAIRP(obj)) return NULL; + v = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + SCHEME_CLOSURE_DATA_FLAGS(data) = (short)(SCHEME_INT_VAL(v)); + + if (!SCHEME_PAIRP(obj)) return NULL; + v = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + data->num_params = SCHEME_INT_VAL(v); + if (data->num_params < 0) return NULL; + + if (!SCHEME_PAIRP(obj)) return NULL; + data->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); + if (data->max_let_depth < 0) return NULL; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return NULL; + tl_map = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + if (!SCHEME_FALSEP(tl_map)) { + if (SCHEME_INTP(tl_map)) + data->tl_map = (void *)tl_map; + else if (SCHEME_VECTORP(tl_map)) { + int *n, i, len, v1, v2; + len = SCHEME_VEC_SIZE(tl_map); + if (len & 0x1) + return NULL; + n = (int *)scheme_malloc_atomic(((len/2) + 1) * sizeof(int)); + n[0] = len/2; + for (i = 0; i < len/2; i++) { + v1 = SCHEME_INT_VAL(SCHEME_VEC_ELS(tl_map)[2*i]); + v2 = SCHEME_INT_VAL(SCHEME_VEC_ELS(tl_map)[(2*i) + 1]); + v2 = (v2 << 16) | v1; + n[i+1] = v2; + } + if ((len == 2) && (!(n[1] & 0x80000000))) + data->tl_map = (void *)(intptr_t)((n[1] << 1) | 0x1); + else + data->tl_map = n; + } else + return NULL; + } + + if (!SCHEME_PAIRP(obj)) return NULL; + data->name = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + if (SCHEME_NULLP(data->name)) + data->name = NULL; + + if (!SCHEME_PAIRP(obj)) return NULL; + v = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + /* v is an svector or an integer... */ + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + if (!SCHEME_INTP(v)) return NULL; + data->closure_size = SCHEME_INT_VAL(v); + + if (!SCHEME_PAIRP(obj)) return NULL; + v = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + } + + data->code = obj; + + if (!SAME_TYPE(scheme_svector_type, SCHEME_TYPE(v))) return NULL; + + if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS)) + data->closure_size = SCHEME_SVEC_LEN(v); + data->closure_map = SCHEME_SVEC_VEC(v); + + /* If the closure is empty, create the closure now */ + if (!data->closure_size) + return scheme_make_closure(NULL, (Scheme_Object *)data, 0); + else + return (Scheme_Object *)data; +} + + +static Scheme_Object *write_toplevel(Scheme_Object *obj) +{ + int pos, flags; + Scheme_Object *pr; + + pos = SCHEME_TOPLEVEL_POS(obj); + flags = (SCHEME_TOPLEVEL_FLAGS(obj) & SCHEME_TOPLEVEL_FLAGS_MASK); + + pr = (flags + ? scheme_make_pair(scheme_make_integer(pos), + scheme_make_integer(flags)) + : scheme_make_integer(pos)); + + return scheme_make_pair(scheme_make_integer(SCHEME_TOPLEVEL_DEPTH(obj)), + pr); +} + +static Scheme_Object *read_toplevel(Scheme_Object *obj) +{ + int pos, depth, flags; + + if (!SCHEME_PAIRP(obj)) return NULL; + + depth = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + + if (SCHEME_PAIRP(obj)) { + pos = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); + flags = SCHEME_INT_VAL(SCHEME_CDR(obj)) & SCHEME_TOPLEVEL_FLAGS_MASK; + } else { + pos = (int)SCHEME_INT_VAL(obj); + flags = 0; + } + + return scheme_make_toplevel(depth, pos, 1, flags); +} + +static Scheme_Object *write_variable(Scheme_Object *obj) + /* #%kernel references are handled in print.c, instead */ +{ + Scheme_Object *sym; + Scheme_Env *home; + Scheme_Module *m; + + sym = (Scheme_Object *)(SCHEME_VAR_BUCKET(obj))->key; + + home = scheme_get_bucket_home((Scheme_Bucket *)obj); + m = home->module; + + /* If we get a writeable variable (instead of a module variable), + it must be a reference to a module referenced directly by its + a symbolic name (i.e., no path). */ + + if (m) { + sym = scheme_make_pair(m->modname, sym); + if (home->mod_phase) + sym = scheme_make_pair(scheme_make_integer(home->mod_phase), sym); + } + + return sym; +} + +static Scheme_Object *read_variable(Scheme_Object *obj) + /* #%kernel references are handled in read.c, instead */ +{ + Scheme_Env *env; + + env = scheme_get_env(NULL); + + if (!SCHEME_SYMBOLP(obj)) return NULL; + + return (Scheme_Object *)scheme_global_bucket(obj, env); +} + +static Scheme_Object *write_module_variable(Scheme_Object *obj) +{ + scheme_signal_error("module variables should have been handled in print.c"); + return NULL; +} + +static Scheme_Object *read_module_variable(Scheme_Object *obj) +{ + scheme_signal_error("module variables should have been handled in read.c"); + return NULL; +} + +static Scheme_Object *write_local(Scheme_Object *obj) +{ + return scheme_make_integer(SCHEME_LOCAL_POS(obj)); +} + +static Scheme_Object *do_read_local(Scheme_Type t, Scheme_Object *obj) +{ + int n, flags; + + if (SCHEME_PAIRP(obj)) { + flags = (int)SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + } else + flags = 0; + + n = (int)SCHEME_INT_VAL(obj); + + return scheme_make_local(t, n, flags); +} + +static Scheme_Object *read_local(Scheme_Object *obj) +{ + return do_read_local(scheme_local_type, obj); +} + +static Scheme_Object *read_local_unbox(Scheme_Object *obj) +{ + return do_read_local(scheme_local_unbox_type, obj); +} + +static Scheme_Object *write_resolve_prefix(Scheme_Object *obj) +{ + Resolve_Prefix *rp = (Resolve_Prefix *)obj; + Scheme_Object *tv, *sv, *ds; + int i; + + i = rp->num_toplevels; + tv = scheme_make_vector(i, NULL); + while (i--) { + SCHEME_VEC_ELS(tv)[i] = rp->toplevels[i]; + } + + i = rp->num_stxes; + sv = scheme_make_vector(i, NULL); + while (i--) { + if (rp->stxes[i]) { + if (SCHEME_INTP(rp->stxes[i])) { + /* Need to foce this object, so we can write it. + This should only happen if we're writing back + code loaded from bytecode. */ + scheme_load_delayed_syntax(rp, i); + } + + ds = scheme_alloc_small_object(); + ds->type = scheme_delay_syntax_type; + SCHEME_PTR_VAL(ds) = rp->stxes[i]; + } else + ds = scheme_false; + SCHEME_VEC_ELS(sv)[i] = ds; + } + + tv = scheme_make_pair(scheme_make_integer(rp->num_lifts), + scheme_make_pair(tv, sv)); + + if (rp->uses_unsafe) + tv = scheme_make_pair(scheme_true, tv); + + return tv; +} + +static Scheme_Object *read_resolve_prefix(Scheme_Object *obj, Scheme_Object *insp) +{ + Resolve_Prefix *rp; + Scheme_Object *tv, *sv, **a, *stx; + intptr_t i; + int uses_unsafe = 0; + + if (!SCHEME_PAIRP(obj)) return NULL; + + if (!SCHEME_INTP(SCHEME_CAR(obj))) { + uses_unsafe = 1; + obj = SCHEME_CDR(obj); + } + + if (!SCHEME_PAIRP(obj)) return NULL; + + i = SCHEME_INT_VAL(SCHEME_CAR(obj)); + if (i < 0) return NULL; + + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return NULL; + + tv = SCHEME_CAR(obj); + sv = SCHEME_CDR(obj); + + if (!SCHEME_VECTORP(tv)) return NULL; + if (!SCHEME_VECTORP(sv)) return NULL; + + rp = MALLOC_ONE_TAGGED(Resolve_Prefix); + rp->so.type = scheme_resolve_prefix_type; + rp->num_toplevels = (int)SCHEME_VEC_SIZE(tv); + rp->num_stxes = (int)SCHEME_VEC_SIZE(sv); + rp->num_lifts = (int)i; + if (uses_unsafe) + rp->uses_unsafe = insp; + + i = rp->num_toplevels; + a = MALLOC_N(Scheme_Object *, i); + while (i--) { + a[i] = SCHEME_VEC_ELS(tv)[i]; + } + rp->toplevels = a; + + i = rp->num_stxes; + a = MALLOC_N(Scheme_Object *, i); + while (i--) { + stx = SCHEME_VEC_ELS(sv)[i]; + if (SCHEME_FALSEP(stx)) { + stx = NULL; + } else if (SCHEME_RPAIRP(stx)) { + struct Scheme_Load_Delay *d; + Scheme_Object *pr; + d = (struct Scheme_Load_Delay *)SCHEME_CDR(stx); + stx = SCHEME_CAR(stx); + pr = rp->delay_info_rpair; + if (!pr) { + pr = scheme_make_raw_pair(scheme_make_integer(0), (Scheme_Object *)d); + rp->delay_info_rpair = pr; + } + SCHEME_CAR(pr) = scheme_make_integer(SCHEME_INT_VAL(SCHEME_CAR(pr)) + 1); + } else { + if (!SCHEME_STXP(stx)) return NULL; + } + a[i] = stx; + } + rp->stxes = a; + + return (Scheme_Object *)rp; +} + +XFORM_NONGCING static Scheme_Object *wrap_mod_stx(Scheme_Object *stx) +{ + return (stx ? stx : scheme_false); +} + +static Scheme_Object *write_module(Scheme_Object *obj) +{ + Scheme_Module *m = (Scheme_Module *)obj; + Scheme_Module_Phase_Exports *pt; + Scheme_Object *l, *v; + int i, k, count, cnt; + + l = scheme_null; + cnt = 0; + if (m->other_requires) { + for (i = 0; i < m->other_requires->size; i++) { + if (m->other_requires->vals[i]) { + cnt++; + l = scheme_make_pair(m->other_requires->keys[i], + scheme_make_pair(m->other_requires->vals[i], + l)); + } + } + } + l = cons(scheme_make_integer(cnt), l); + + l = cons(m->dt_requires, l); + l = cons(m->tt_requires, l); + l = cons(m->et_requires, l); + l = cons(m->requires, l); + + l = cons(m->body, l); + l = cons(m->et_body, l); + + cnt = 0; + for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) { + switch (k) { + case -3: + pt = m->me->dt; + break; + case -2: + pt = m->me->et; + break; + case -1: + pt = m->me->rt; + break; + default: + pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k]; + } + + if (pt) { + l = cons(scheme_make_integer(pt->num_provides), l); + l = cons(scheme_make_integer(pt->num_var_provides), l); + + count = pt->num_provides; + + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = pt->provides[i]; + } + l = cons(v, l); + + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = pt->provide_srcs[i]; + } + l = cons(v, l); + + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = pt->provide_src_names[i]; + } + l = cons(v, l); + + if (pt->provide_nominal_srcs) { + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = pt->provide_nominal_srcs[i]; + } + l = cons(v, l); + } else { + l = cons(scheme_false, l); + } + + if (pt->provide_src_phases) { + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = (pt->provide_src_phases[i] ? scheme_true : scheme_false); + } + } else + v = scheme_false; + l = cons(v, l); + + if (pt->provide_insps) { + v = scheme_make_vector(count, scheme_false); + for (i = 0; i < count; i++) { + if (pt->provide_insps[i]) { + if (SCHEME_PAIRP(pt->provide_insps[i])) + SCHEME_VEC_ELS(v)[i] = scheme_void; + else + SCHEME_VEC_ELS(v)[i] = scheme_true; + } + } + } else + v = scheme_false; + l = cons(v, l); + + l = cons(pt->phase_index, l); + cnt++; + } + } + + l = cons(scheme_make_integer(cnt), l); + + count = m->me->rt->num_provides; + if (m->provide_protects) { + for (i = 0; i < count; i++) { + if (m->provide_protects[i]) + break; + } + if (i < count) { + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = (m->provide_protects[i] ? scheme_true : scheme_false); + } + } else + v = scheme_false; + l = cons(v, l); + } else + l = cons(scheme_false, l); + + count = m->me->et->num_provides; + if (m->et_provide_protects) { + for (i = 0; i < count; i++) { + if (m->et_provide_protects[i]) + break; + } + if (i < count) { + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = (m->et_provide_protects[i] ? scheme_true : scheme_false); + } + } else + v = scheme_false; + l = cons(v, l); + } else + l = cons(scheme_false, l); + + count = m->num_indirect_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = m->indirect_provides[i]; + } + l = cons(v, l); + + count = m->num_indirect_syntax_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = m->indirect_syntax_provides[i]; + } + l = cons(v, l); + + count = m->num_indirect_et_provides; + l = cons(scheme_make_integer(count), l); + v = scheme_make_vector(count, NULL); + for (i = 0; i < count; i++) { + SCHEME_VEC_ELS(v)[i] = m->et_indirect_provides[i]; + } + l = cons(v, l); + + l = cons((Scheme_Object *)m->prefix, l); + l = cons(m->dummy, l); + + l = cons(scheme_make_integer(m->max_let_depth), l); + + l = cons(wrap_mod_stx(m->rn_stx), l); + + /* previously recorded "functional?" info: */ + l = cons(scheme_false, l); + l = cons(scheme_false, l); + + if (m->lang_info) + l = cons(m->lang_info, l); + else + l = cons(scheme_false, l); + + l = cons(m->me->src_modidx, l); + l = cons(scheme_resolved_module_path_value(m->modsrc), l); + l = cons(scheme_resolved_module_path_value(m->modname), l); + + return l; +} + +static int check_requires_ok(Scheme_Object *l) +{ + Scheme_Object *x; + while (!SCHEME_NULLP(l)) { + x = SCHEME_CAR(l); + if (!SAME_TYPE(SCHEME_TYPE(x), scheme_module_index_type)) + return 0; + l = SCHEME_CDR(l); + } + return 1; +} + +#if 0 +# define return_NULL() return (printf("%d\n", __LINE__), NULL) +#else +# define return_NULL() return NULL +#endif + +static Scheme_Object *read_module(Scheme_Object *obj) +{ + Scheme_Module *m; + Scheme_Object *ie, *nie, *insp; + Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *einsp, *e, *nve, *ne, **v; + Scheme_Module_Exports *me; + Scheme_Module_Phase_Exports *pt; + char *ps, *sps; + int i, count, cnt; + + m = MALLOC_ONE_TAGGED(Scheme_Module); + m->so.type = scheme_module_type; + + me = scheme_make_module_exports(); + m->me = me; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); + m->modname = e; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); + m->modsrc = e; + m->me->modsrc = e; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + me->src_modidx = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + ((Scheme_Modidx *)m->me->src_modidx)->resolved = m->modname; + m->self_modidx = m->me->src_modidx; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = SCHEME_CAR(obj); + if (SCHEME_FALSEP(e)) + e = NULL; + else if (!(SCHEME_VECTORP(e) + && (3 == SCHEME_VEC_SIZE(e)) + && scheme_is_module_path(SCHEME_VEC_ELS(e)[0]) + && SCHEME_SYMBOLP(SCHEME_VEC_ELS(e)[1]))) + return_NULL(); + m->lang_info = e; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + /* "functional?" info ignored */ + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + /* "functional?" info ignored */ + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + m->rn_stx = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + if (SCHEME_FALSEP(m->rn_stx)) + m->rn_stx = NULL; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + m->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + m->dummy = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + m->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + m->et_indirect_provides = v; + m->num_indirect_et_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + m->indirect_syntax_provides = v; + m->num_indirect_syntax_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + ie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nie = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(nie); + + if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(ie)[i]; + } + m->indirect_provides = v; + m->num_indirect_provides = count; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + eesp = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + esp = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + + while (cnt--) { + Scheme_Object *phase; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + phase = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_FALSEP(phase) + && !SCHEME_INTP(phase) + && !SCHEME_BIGNUMP(phase)) + return_NULL(); + + if (SAME_OBJ(phase, scheme_make_integer(0))) { + pt = me->rt; + } else if (SAME_OBJ(phase, scheme_make_integer(1))) { + pt = me->et; + } else if (SAME_OBJ(phase, scheme_false)) { + pt = me->dt; + } else { + pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); + pt->so.type = scheme_module_phase_exports_type; + pt->phase_index = phase; + if (!me->other_phases) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table_equal(); + me->other_phases = ht; + } + scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); + } + + if (!SCHEME_PAIRP(obj)) return_NULL(); + einsp = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + esph = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + esnom = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + esn = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + es = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + nve = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + ne = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + count = SCHEME_INT_VAL(ne); + pt->num_provides = count; + pt->num_var_provides = SCHEME_INT_VAL(nve); + + if (!SCHEME_VECTORP(e) || (SCHEME_VEC_SIZE(e) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(e)[i]; + } + pt->provides = v; + + if (!SCHEME_VECTORP(es) || (SCHEME_VEC_SIZE(es) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(es)[i]; + } + pt->provide_srcs = v; + + if (!SCHEME_VECTORP(esn) || (SCHEME_VEC_SIZE(esn) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(esn)[i]; + } + pt->provide_src_names = v; + + if (SCHEME_FALSEP(esnom)) { + pt->provide_nominal_srcs = NULL; + } else { + if (!SCHEME_VECTORP(esnom) || (SCHEME_VEC_SIZE(esnom) != count)) return_NULL(); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + v[i] = SCHEME_VEC_ELS(esnom)[i]; + } + pt->provide_nominal_srcs = v; + } + + if (SCHEME_FALSEP(esph)) + sps = NULL; + else { + if (!SCHEME_VECTORP(esph) || (SCHEME_VEC_SIZE(esph) != count)) return_NULL(); + sps = MALLOC_N_ATOMIC(char, count); + for (i = 0; i < count; i++) { + sps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esph)[i]); + } + } + pt->provide_src_phases = sps; + + if (SCHEME_FALSEP(einsp)) { + pt->provide_insps = NULL; + } else { + if (!SCHEME_VECTORP(einsp) || (SCHEME_VEC_SIZE(einsp) != count)) return_NULL(); + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + if (SCHEME_TRUEP(SCHEME_VEC_ELS(einsp)[i])) { + if (SCHEME_VOIDP(SCHEME_VEC_ELS(einsp)[i])) { + e = cons(scheme_false, insp); + v[i] = e; + } else + v[i] = insp; + } + } + pt->provide_insps = v; + } + } + + count = me->rt->num_provides; + + if (SCHEME_FALSEP(esp)) { + m->provide_protects = NULL; + } else { + if (!SCHEME_VECTORP(esp) || (SCHEME_VEC_SIZE(esp) != count)) return_NULL(); + ps = MALLOC_N_ATOMIC(char, count); + for (i = 0; i < count; i++) { + ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); + } + m->provide_protects = ps; + } + + if (SCHEME_FALSEP(eesp)) { + m->et_provide_protects = NULL; + } else { + if (!SCHEME_VECTORP(eesp) || (SCHEME_VEC_SIZE(eesp) != count)) return_NULL(); + ps = MALLOC_N_ATOMIC(char, count); + for (i = 0; i < count; i++) { + ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(eesp)[i]); + } + m->et_provide_protects = ps; + } + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = SCHEME_CAR(obj); + if (!SCHEME_VECTORP(e)) return_NULL(); + m->et_body = e; + for (i = SCHEME_VEC_SIZE(e); i--; ) { + e = SCHEME_VEC_ELS(m->et_body)[i]; + if (!SCHEME_VECTORP(e)) return_NULL(); + /* SCHEME_VEC_ELS(e)[1] should be code */ + if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) + return_NULL(); + e = SCHEME_VEC_ELS(e)[0]; + if (!SCHEME_SYMBOLP(e)) { + while (SCHEME_PAIRP(e)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); + e = SCHEME_CDR(e); + } + if (!SCHEME_NULLP(e)) return_NULL(); + } + } + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = SCHEME_CAR(obj); + if (!SCHEME_VECTORP(e)) return_NULL(); + m->body = e; + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); + e = scheme_copy_list(SCHEME_CAR(obj)); + m->requires = e; + if (!check_requires_ok(e)) return_NULL(); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); + e = scheme_copy_list(SCHEME_CAR(obj)); + m->et_requires = e; + if (!check_requires_ok(e)) return_NULL(); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); + e = scheme_copy_list(SCHEME_CAR(obj)); + m->tt_requires = e; + if (!check_requires_ok(e)) return_NULL(); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); + e = scheme_copy_list(SCHEME_CAR(obj)); + m->dt_requires = e; + if (!check_requires_ok(e)) return_NULL(); + obj = SCHEME_CDR(obj); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); + obj = SCHEME_CDR(obj); + while (cnt--) { + Scheme_Object *phase; + + if (!SCHEME_PAIRP(obj)) return_NULL(); + phase = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + + if (!SCHEME_INTP(phase) + && !SCHEME_BIGNUMP(phase)) + return_NULL(); + + if (SAME_OBJ(phase, scheme_make_integer(0)) + || SAME_OBJ(phase, scheme_make_integer(1)) + || SAME_OBJ(phase, scheme_make_integer(-1))) + return_NULL(); + + if (!SCHEME_PAIRP(obj)) return_NULL(); + e = scheme_copy_list(SCHEME_CAR(obj)); + if (!check_requires_ok(e)) return_NULL(); + + if (!m->other_requires) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table_equal(); + m->other_requires = ht; + } + scheme_hash_set(m->other_requires, phase, e); + + obj = SCHEME_CDR(obj); + } + + return (Scheme_Object *)m; +} + +Scheme_Object *write_top_level_require(Scheme_Object *o) +{ + return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); +} + +Scheme_Object *read_top_level_require(Scheme_Object *o) +{ + Scheme_Object *data; + + if (!SCHEME_PAIRP(o)) return NULL; + + data = scheme_alloc_object(); + data->type = scheme_require_form_type; + SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); + SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); + + return data; +} diff --git a/src/racket/src/module.c b/src/racket/src/module.c index 2e6f399577..1796d0830b 100644 --- a/src/racket/src/module.c +++ b/src/racket/src/module.c @@ -88,11 +88,6 @@ static Scheme_Object *require_expand(Scheme_Object *form, Scheme_Comp_Env *env, static Scheme_Object *provide_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); static Scheme_Object *provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *write_module(Scheme_Object *obj); -static Scheme_Object *read_module(Scheme_Object *obj); -static Scheme_Object *read_top_level_require(Scheme_Object *obj); -static Scheme_Object *write_top_level_require(Scheme_Object *obj); - static Scheme_Module *module_load(Scheme_Object *modname, Scheme_Env *env, const char *who); static void run_module(Scheme_Env *menv, int set_ns); @@ -106,8 +101,6 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Object *certs, Scheme_Object *free_id_rename_rn); -static Scheme_Module_Exports *make_module_exports(); - static Scheme_Object *scheme_sys_wraps_phase_worker(intptr_t p); #define cons scheme_make_pair @@ -347,11 +340,6 @@ void scheme_init_module(Scheme_Env *env) module_symbol = scheme_intern_symbol("module"); module_begin_symbol = scheme_intern_symbol("#%module-begin"); - scheme_install_type_writer(scheme_module_type, write_module); - scheme_install_type_reader(scheme_module_type, read_module); - scheme_install_type_writer(scheme_require_form_type, write_top_level_require); - scheme_install_type_reader(scheme_require_form_type, read_top_level_require); - GLOBAL_PARAMETER("current-module-name-resolver", current_module_name_resolver, MZCONFIG_CURRENT_MODULE_RESOLVER, env); GLOBAL_PARAMETER("current-module-declare-name", current_module_name_prefix, MZCONFIG_CURRENT_MODULE_NAME, env); GLOBAL_PARAMETER("current-module-declare-source", current_module_name_source, MZCONFIG_CURRENT_MODULE_SRC, env); @@ -482,7 +470,7 @@ void scheme_finish_kernel(Scheme_Env *env) { Scheme_Module_Exports *me; - me = make_module_exports(); + me = scheme_make_module_exports(); kernel->me = me; kernel->me->modsrc = kernel_modname; } @@ -4831,7 +4819,7 @@ Scheme_Env *scheme_primitive_module(Scheme_Object *name, Scheme_Env *for_env) { Scheme_Module_Exports *me; - me = make_module_exports(); + me = scheme_make_module_exports(); m->me = me; me->modsrc = src; } @@ -4981,7 +4969,7 @@ Scheme_Module *scheme_extract_compiled_module(Scheme_Object *o) return NULL; } -static Scheme_Module_Exports *make_module_exports() +Scheme_Module_Exports *scheme_make_module_exports() { Scheme_Module_Exports *me; Scheme_Module_Phase_Exports *pt; @@ -5469,492 +5457,6 @@ Scheme_Object *scheme_module_eval_clone(Scheme_Object *data) return do_module_clone(data, 0); } -void scheme_module_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - Scheme_Module *m; - int i, cnt, let_depth; - Resolve_Prefix *rp; - Scheme_Object *e; - - m = (Scheme_Module *)data; - - if (!SCHEME_MODNAMEP(m->modname)) - scheme_ill_formed_code(port); - - scheme_validate_code(port, m->body, m->max_let_depth, - m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts, - NULL, - 1); - - /* validate exp-time code */ - cnt = SCHEME_VEC_SIZE(m->et_body); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->et_body)[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; - e = SCHEME_VEC_ELS(e)[1]; - - scheme_validate_code(port, e, let_depth, - rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, - 0); - } -} - -static int set_code_closure_flags(Scheme_Object *clones, - int set_flags, int mask_flags, - int just_tentative) -{ - Scheme_Object *clone, *orig, *first; - Scheme_Closure_Data *data; - int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS; - - /* The first in a clone pair is the one that is consulted for - references. The second one is the original, and its the one whose - flags are updated by optimization. So consult the original, and set - flags in both. */ - - while (clones) { - first = SCHEME_CAR(clones); - clone = SCHEME_CAR(first); - orig = SCHEME_CDR(first); - - data = (Scheme_Closure_Data *)orig; - if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { - flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data)); - SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags); - data = (Scheme_Closure_Data *)clone; - SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags); - } - - clones = SCHEME_CDR(clones); - } - - return flags; -} - -Scheme_Object * -scheme_module_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *e, *vars, *old_context; - int start_simltaneous = 0, i_m, cnt; - Scheme_Object *cl_first = NULL, *cl_last = NULL; - Scheme_Hash_Table *consts = NULL, *ready_table = NULL, *re_consts = NULL; - int cont, next_pos_ready = -1, inline_fuel, is_proc_def; - - old_context = info->context; - info->context = (Scheme_Object *)m; - - cnt = SCHEME_VEC_SIZE(m->body); - - if (OPT_ESTIMATE_FUTURE_SIZES) { - if (info->enforce_const) { - /* For each identifier bound to a procedure, register an initial - size estimate, which is used to discourage early loop unrolling - at the expense of later inlining. */ - for (i_m = 0; i_m < cnt; i_m++) { - e = SCHEME_VEC_ELS(m->body)[i_m]; - if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { - int n; - - vars = SCHEME_VEC_ELS(e)[0]; - e = SCHEME_VEC_ELS(e)[1]; - - n = scheme_list_length(vars); - if (n == 1) { - if (IS_COMPILED_PROC(e)) { - Scheme_Toplevel *tl; - - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, - scheme_make_integer(pos), - scheme_estimate_closure_size(e)); - } - } - } - } - } - - if (consts) { - info->top_level_consts = consts; - consts = NULL; - } - } - } - - for (i_m = 0; i_m < cnt; i_m++) { - /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; - - is_proc_def = 0; - if (OPT_DISCOURAGE_EARLY_INLINE && info->enforce_const) { - if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { - Scheme_Object *e2; - e2 = (Scheme_Object *)e; - e2 = SCHEME_VEC_ELS(e2)[1]; - if (IS_COMPILED_PROC(e2)) - is_proc_def = 1; - } - } - - if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { - info->use_psize = 1; - inline_fuel = info->inline_fuel; - if (inline_fuel > 2) - info->inline_fuel = 2; - } else - inline_fuel = 0; - e = scheme_optimize_expr(e, info, 0); - if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { - info->use_psize = 0; - info->inline_fuel = inline_fuel; - } - SCHEME_VEC_ELS(m->body)[i_m] = e; - - if (info->enforce_const) { - /* If this expression/definition can't have any side effect - (including raising an exception), then continue the group of - simultaneous definitions: */ - if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { - int n, cnst = 0, sproc = 0; - - vars = SCHEME_VEC_ELS(e)[0]; - e = SCHEME_VEC_ELS(e)[1]; - - n = scheme_list_length(vars); - cont = scheme_omittable_expr(e, n, -1, 0, info, -1); - - if (n == 1) { - if (scheme_compiled_propagate_ok(e, info)) - cnst = 1; - else if (scheme_is_statically_proc(e, info)) { - cnst = 1; - sproc = 1; - } - } - - if (cnst) { - Scheme_Toplevel *tl; - - tl = (Scheme_Toplevel *)SCHEME_CAR(vars); - - if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { - Scheme_Object *e2; - - if (sproc) { - e2 = scheme_make_noninline_proc(e); - } else if (IS_COMPILED_PROC(e)) { - e2 = scheme_optimize_clone(1, e, info, 0, 0); - if (e2) { - Scheme_Object *pr; - pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL); - if (cl_last) - SCHEME_CDR(cl_last) = pr; - else - cl_first = pr; - cl_last = pr; - } else - e2 = scheme_make_noninline_proc(e); - } else { - e2 = e; - } - - if (e2) { - int pos; - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - pos = tl->position; - scheme_hash_set(consts, scheme_make_integer(pos), e2); - if (!re_consts) - re_consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(re_consts, scheme_make_integer(i_m), - scheme_make_integer(pos)); - } else { - /* At least mark it as ready */ - if (!ready_table) { - ready_table = scheme_make_hash_table(SCHEME_hash_ptr); - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table); - } - scheme_hash_set(ready_table, scheme_make_integer(tl->position), scheme_true); - } - } - } else { - /* The binding is not inlinable/propagatable, but unless it's - set!ed, it is constant after evaluating the definition. We - map the top-level position to indicate constantness. */ - Scheme_Object *l, *a; - int pos; - - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - - /* Test for ISCONST to indicate no set!: */ - if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) { - pos = SCHEME_TOPLEVEL_POS(a); - - next_pos_ready = pos; - } - } - } - } else { - cont = scheme_omittable_expr(e, -1, -1, 0, NULL, -1); - } - if (i_m + 1 == cnt) - cont = 0; - } else - cont = 1; - - if (!cont) { - /* If we have new constants, re-optimize to inline: */ - if (consts) { - int flags; - - if (!info->top_level_consts) { - info->top_level_consts = consts; - } else { - int i; - for (i = 0; i < consts->size; i++) { - if (consts->vals[i]) { - scheme_hash_set(info->top_level_consts, - consts->keys[i], - consts->vals[i]); - } - } - } - - /* Same as in letrec: assume CLOS_SINGLE_RESULT and - CLOS_PRESERVES_MARKS for all, but then assume not for all - if any turn out not (i.e., approximate fix point). */ - (void)set_code_closure_flags(cl_first, - CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, - 0xFFFF, - 0); - - while (1) { - /* Re-optimize this expression. We can optimize anything without - shift-cloning, since there are no local variables in scope. */ - int old_sz, new_sz; - - e = SCHEME_VEC_ELS(m->body)[start_simltaneous]; - - if (OPT_LIMIT_FUNCTION_RESIZE) { - if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { - Scheme_Object *sub_e; - sub_e = SCHEME_VEC_ELS(e)[1]; - if (IS_COMPILED_PROC(sub_e)) - old_sz = scheme_compiled_proc_body_size(sub_e); - else - old_sz = 0; - } else - old_sz = 0; - } else - old_sz = 0; - - e = scheme_optimize_expr(e, info, 0); - SCHEME_VEC_ELS(m->body)[start_simltaneous] = e; - - if (re_consts) { - /* Install optimized closures into constant table --- - unless, maybe, they grow too much: */ - Scheme_Object *rpos; - rpos = scheme_hash_get(re_consts, scheme_make_integer(start_simltaneous)); - if (rpos) { - e = SCHEME_VEC_ELS(e)[1]; - if (!scheme_compiled_propagate_ok(e, info) - && scheme_is_statically_proc(e, info)) { - /* If we previously installed a procedure for inlining, - don't replace that with a worse approximation. */ - Scheme_Object *old_e; - old_e = scheme_hash_get(info->top_level_consts, rpos); - if (IS_COMPILED_PROC(old_e)) - e = NULL; - else - e = scheme_make_noninline_proc(e); - } - - if (e) { - if (OPT_LIMIT_FUNCTION_RESIZE) { - if (IS_COMPILED_PROC(e)) - new_sz = scheme_compiled_proc_body_size(e); - else - new_sz = 0; - } else - new_sz = 0; - - if (!new_sz || !old_sz || (new_sz < 4 * old_sz)) - scheme_hash_set(info->top_level_consts, rpos, e); - } - } - } - - if (start_simltaneous == i_m) - break; - start_simltaneous++; - } - - flags = set_code_closure_flags(cl_first, 0, 0xFFFF, 0); - (void)set_code_closure_flags(cl_first, - (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), - ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE), - 1); - } - - cl_last = cl_first = NULL; - consts = NULL; - re_consts = NULL; - start_simltaneous = i_m + 1; - } - - if (next_pos_ready > -1) { - if (!ready_table) { - ready_table = scheme_make_hash_table(SCHEME_hash_ptr); - if (!consts) - consts = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table); - } - scheme_hash_set(ready_table, scheme_make_integer(next_pos_ready), scheme_true); - next_pos_ready = -1; - } - } - - /* Check one more time for expressions that we can omit: */ - { - int can_omit = 0; - for (i_m = 0; i_m < cnt; i_m++) { - /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; - if (scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { - can_omit++; - } - } - if (can_omit) { - Scheme_Object *vec; - int j = 0; - vec = scheme_make_vector(cnt - can_omit, NULL); - for (i_m = 0; i_m < cnt; i_m++) { - /* Optimize this expression: */ - e = SCHEME_VEC_ELS(m->body)[i_m]; - if (!scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { - SCHEME_VEC_ELS(vec)[j++] = e; - } - } - m->body = vec; - } - } - - info->context = old_context; - - /* Exp-time body was optimized during compilation */ - - return data; -} - -Scheme_Object * -scheme_module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *b, *lift_vec; - Resolve_Prefix *rp; - Resolve_Info *rslv; - int i, cnt; - - rp = scheme_resolve_prefix(0, m->comp_prefix, 1); - m->comp_prefix = NULL; - - b = scheme_resolve_expr(m->dummy, old_rslv); - m->dummy = b; - - rslv = scheme_resolve_info_create(rp); - rslv->enforce_const = old_rslv->enforce_const; - rslv->in_module = 1; - scheme_enable_expression_resolve_lifts(rslv); - - cnt = SCHEME_VEC_SIZE(m->body); - for (i = 0; i < cnt; i++) { - Scheme_Object *e; - e = scheme_resolve_expr(SCHEME_VEC_ELS(m->body)[i], rslv); - SCHEME_VEC_ELS(m->body)[i] = e; - } - - m->max_let_depth = rslv->max_let_depth; - - lift_vec = rslv->lifts; - if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { - b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], scheme_vector_to_list(m->body)); - b = scheme_list_to_vector(b); - m->body = b; - } - rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); - - rp = scheme_remap_prefix(rp, rslv); - - m->prefix = rp; - - /* Exp-time body was resolved during compilation */ - - return data; -} - -Scheme_Object * -scheme_module_sfs(Scheme_Object *data, SFS_Info *old_info) -{ - Scheme_Module *m = (Scheme_Module *)data; - Scheme_Object *e, *ex; - SFS_Info *info; - int i, cnt, let_depth; - - if (!old_info->for_mod) { - if (old_info->pass) - return data; - - info = scheme_new_sfs_info(m->max_let_depth); - info->for_mod = 1; - scheme_sfs(data, info, m->max_let_depth); - return data; - } - - info = old_info; - - cnt = SCHEME_VEC_SIZE(m->body); - scheme_sfs_start_sequence(info, cnt, 0); - - for (i = 0; i < cnt; i++) { - e = scheme_sfs_expr(SCHEME_VEC_ELS(m->body)[i], info, -1); - SCHEME_VEC_ELS(m->body)[i] = e; - } - - if (!info->pass) { - cnt = SCHEME_VEC_SIZE(m->et_body); - for (i = 0; i < cnt; i++) { - e = SCHEME_VEC_ELS(m->et_body)[i]; - - let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); - ex = SCHEME_VEC_ELS(e)[1]; - - info = scheme_new_sfs_info(let_depth); - ex = scheme_sfs(ex, info, let_depth); - SCHEME_VEC_ELS(e)[1] = ex; - } - } - - return data; -} - #if 0 # define LOG_EXPAND_DECLS intptr_t start_time # define LOG_START_EXPAND(mod) (start_time = scheme_get_process_milliseconds()) @@ -6028,7 +5530,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, { Scheme_Module_Exports *me; - me = make_module_exports(); + me = scheme_make_module_exports(); m->me = me; me->modsrc = m->modsrc; } @@ -6905,6 +6407,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, int count = 0; int for_stx; int use_post_ex = 0; + int max_let_depth; for_stx = scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0); @@ -7011,9 +6514,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, lifted_reqs = scheme_append(scheme_frame_get_require_lifts(eenv), lifted_reqs); oi = scheme_optimize_info_create(); - oi->context = (Scheme_Object *)env->genv->module; + scheme_optimize_info_set_context(oi, (Scheme_Object *)env->genv->module); if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - oi->inline_fuel = -1; + scheme_optimize_info_never_inline(oi); m = scheme_optimize_expr(m, oi, 0); /* Simplify only in compile mode; it is too slow in expand mode. */ @@ -7024,23 +6527,25 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, m = scheme_merge_expression_resolve_lifts(m, rp, ri); rp = scheme_remap_prefix(rp, ri); + max_let_depth = scheme_resolve_info_max_let_depth(ri); + /* Add code with names and lexical depth to exp-time body: */ vec = scheme_make_vector(5, NULL); SCHEME_VEC_ELS(vec)[0] = ((SCHEME_PAIRP(names) && SCHEME_NULLP(SCHEME_CDR(names))) ? SCHEME_CAR(names) : names); SCHEME_VEC_ELS(vec)[1] = m; - SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(ri->max_let_depth); + SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(max_let_depth); SCHEME_VEC_ELS(vec)[3] = (Scheme_Object *)rp; SCHEME_VEC_ELS(vec)[4] = (for_stx ? scheme_true : scheme_false); exp_body = scheme_make_pair(vec, exp_body); - m = scheme_sfs(m, NULL, ri->max_let_depth); - if (ri->use_jit) + m = scheme_sfs(m, NULL, max_let_depth); + if (scheme_resolve_info_use_jit(ri)) m = scheme_jit_expr(m); rp = scheme_prefix_eval_clone(rp); - eval_exptime(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0, + eval_exptime(names, count, m, eenv->genv, rhs_env, rp, max_let_depth, 0, (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx, rec[drec].certs, for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn)); @@ -9276,7 +8781,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ } else exns = scheme_null; - /* The format of this data is checked in stxobj for unmarshaling + /* The format of this data is checked in "syntax.c" for unmarshaling a Module_Renames. Also the idx must be first, to support shifting. */ info = cons(orig_idx, cons(pt->phase_index, cons(src_phase_index, @@ -9880,40 +9385,6 @@ scheme_top_level_require_jit(Scheme_Object *data) return data; } -void scheme_top_level_require_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ -} - -Scheme_Object * -scheme_top_level_require_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - return data; -} - -Scheme_Object * -scheme_top_level_require_resolve(Scheme_Object *data, Resolve_Info *rslv) -{ - Scheme_Object *dummy = SCHEME_PTR1_VAL(data); - - dummy = scheme_resolve_expr(dummy, rslv); - - SCHEME_PTR1_VAL(data) = dummy; - - return data; -} - -Scheme_Object * -scheme_top_level_require_sfs(Scheme_Object *data, SFS_Info *rslv) -{ - return data; -} - static Scheme_Object *do_require(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Expand_Info *rec, int drec) { @@ -10010,620 +9481,3 @@ provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er scheme_wrong_syntax(NULL, NULL, form, "not in module body"); return NULL; } - -/**********************************************************************/ -/* marshal/unmarshal */ -/**********************************************************************/ - -XFORM_NONGCING static Scheme_Object *wrap_mod_stx(Scheme_Object *stx) -{ - return (stx ? stx : scheme_false); -} - -static Scheme_Object *write_module(Scheme_Object *obj) -{ - Scheme_Module *m = (Scheme_Module *)obj; - Scheme_Module_Phase_Exports *pt; - Scheme_Object *l, *v; - int i, k, count, cnt; - - l = scheme_null; - cnt = 0; - if (m->other_requires) { - for (i = 0; i < m->other_requires->size; i++) { - if (m->other_requires->vals[i]) { - cnt++; - l = scheme_make_pair(m->other_requires->keys[i], - scheme_make_pair(m->other_requires->vals[i], - l)); - } - } - } - l = cons(scheme_make_integer(cnt), l); - - l = cons(m->dt_requires, l); - l = cons(m->tt_requires, l); - l = cons(m->et_requires, l); - l = cons(m->requires, l); - - l = cons(m->body, l); - l = cons(m->et_body, l); - - cnt = 0; - for (k = -3; k < (m->me->other_phases ? m->me->other_phases->size : 0); k++) { - switch (k) { - case -3: - pt = m->me->dt; - break; - case -2: - pt = m->me->et; - break; - case -1: - pt = m->me->rt; - break; - default: - pt = (Scheme_Module_Phase_Exports *)m->me->other_phases->vals[k]; - } - - if (pt) { - l = cons(scheme_make_integer(pt->num_provides), l); - l = cons(scheme_make_integer(pt->num_var_provides), l); - - count = pt->num_provides; - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provides[i]; - } - l = cons(v, l); - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_srcs[i]; - } - l = cons(v, l); - - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_src_names[i]; - } - l = cons(v, l); - - if (pt->provide_nominal_srcs) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = pt->provide_nominal_srcs[i]; - } - l = cons(v, l); - } else { - l = cons(scheme_false, l); - } - - if (pt->provide_src_phases) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (pt->provide_src_phases[i] ? scheme_true : scheme_false); - } - } else - v = scheme_false; - l = cons(v, l); - - if (pt->provide_insps) { - v = scheme_make_vector(count, scheme_false); - for (i = 0; i < count; i++) { - if (pt->provide_insps[i]) { - if (SCHEME_PAIRP(pt->provide_insps[i])) - SCHEME_VEC_ELS(v)[i] = scheme_void; - else - SCHEME_VEC_ELS(v)[i] = scheme_true; - } - } - } else - v = scheme_false; - l = cons(v, l); - - l = cons(pt->phase_index, l); - cnt++; - } - } - - l = cons(scheme_make_integer(cnt), l); - - count = m->me->rt->num_provides; - if (m->provide_protects) { - for (i = 0; i < count; i++) { - if (m->provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (m->provide_protects[i] ? scheme_true : scheme_false); - } - } else - v = scheme_false; - l = cons(v, l); - } else - l = cons(scheme_false, l); - - count = m->me->et->num_provides; - if (m->et_provide_protects) { - for (i = 0; i < count; i++) { - if (m->et_provide_protects[i]) - break; - } - if (i < count) { - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = (m->et_provide_protects[i] ? scheme_true : scheme_false); - } - } else - v = scheme_false; - l = cons(v, l); - } else - l = cons(scheme_false, l); - - count = m->num_indirect_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->indirect_provides[i]; - } - l = cons(v, l); - - count = m->num_indirect_syntax_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->indirect_syntax_provides[i]; - } - l = cons(v, l); - - count = m->num_indirect_et_provides; - l = cons(scheme_make_integer(count), l); - v = scheme_make_vector(count, NULL); - for (i = 0; i < count; i++) { - SCHEME_VEC_ELS(v)[i] = m->et_indirect_provides[i]; - } - l = cons(v, l); - - l = cons((Scheme_Object *)m->prefix, l); - l = cons(m->dummy, l); - - l = cons(scheme_make_integer(m->max_let_depth), l); - - l = cons(wrap_mod_stx(m->rn_stx), l); - - /* previously recorded "functional?" info: */ - l = cons(scheme_false, l); - l = cons(scheme_false, l); - - if (m->lang_info) - l = cons(m->lang_info, l); - else - l = cons(scheme_false, l); - - l = cons(m->me->src_modidx, l); - l = cons(scheme_resolved_module_path_value(m->modsrc), l); - l = cons(scheme_resolved_module_path_value(m->modname), l); - - return l; -} - -static int check_requires_ok(Scheme_Object *l) -{ - Scheme_Object *x; - while (!SCHEME_NULLP(l)) { - x = SCHEME_CAR(l); - if (!SAME_TYPE(SCHEME_TYPE(x), scheme_module_index_type)) - return 0; - l = SCHEME_CDR(l); - } - return 1; -} - -#if 0 -# define return_NULL() return (printf("%d\n", __LINE__), NULL) -#else -# define return_NULL() return NULL -#endif - -static Scheme_Object *read_module(Scheme_Object *obj) -{ - Scheme_Module *m; - Scheme_Object *ie, *nie, *insp; - Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *einsp, *e, *nve, *ne, **v; - Scheme_Module_Exports *me; - Scheme_Module_Phase_Exports *pt; - char *ps, *sps; - int i, count, cnt; - - m = MALLOC_ONE_TAGGED(Scheme_Module); - m->so.type = scheme_module_type; - - me = make_module_exports(); - m->me = me; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); - m->modname = e; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_intern_resolved_module_path(SCHEME_CAR(obj)); - m->modsrc = e; - m->me->modsrc = e; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - me->src_modidx = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - ((Scheme_Modidx *)m->me->src_modidx)->resolved = m->modname; - m->self_modidx = m->me->src_modidx; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (SCHEME_FALSEP(e)) - e = NULL; - else if (!(SCHEME_VECTORP(e) - && (3 == SCHEME_VEC_SIZE(e)) - && scheme_is_module_path(SCHEME_VEC_ELS(e)[0]) - && SCHEME_SYMBOLP(SCHEME_VEC_ELS(e)[1]))) - return_NULL(); - m->lang_info = e; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - /* "functional?" info ignored */ - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - /* "functional?" info ignored */ - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->rn_stx = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (SCHEME_FALSEP(m->rn_stx)) - m->rn_stx = NULL; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->dummy = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - m->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - m->et_indirect_provides = v; - m->num_indirect_et_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - m->indirect_syntax_provides = v; - m->num_indirect_syntax_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nie = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(nie); - - if (!SCHEME_VECTORP(ie) || (SCHEME_VEC_SIZE(ie) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(ie)[i]; - } - m->indirect_provides = v; - m->num_indirect_provides = count; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - eesp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - while (cnt--) { - Scheme_Object *phase; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - phase = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - return_NULL(); - - if (SAME_OBJ(phase, scheme_make_integer(0))) { - pt = me->rt; - } else if (SAME_OBJ(phase, scheme_make_integer(1))) { - pt = me->et; - } else if (SAME_OBJ(phase, scheme_false)) { - pt = me->dt; - } else { - pt = MALLOC_ONE_RT(Scheme_Module_Phase_Exports); - pt->so.type = scheme_module_phase_exports_type; - pt->phase_index = phase; - if (!me->other_phases) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); - me->other_phases = ht; - } - scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - einsp = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esph = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esnom = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - esn = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - es = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - nve = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - ne = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - count = SCHEME_INT_VAL(ne); - pt->num_provides = count; - pt->num_var_provides = SCHEME_INT_VAL(nve); - - if (!SCHEME_VECTORP(e) || (SCHEME_VEC_SIZE(e) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(e)[i]; - } - pt->provides = v; - - if (!SCHEME_VECTORP(es) || (SCHEME_VEC_SIZE(es) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(es)[i]; - } - pt->provide_srcs = v; - - if (!SCHEME_VECTORP(esn) || (SCHEME_VEC_SIZE(esn) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(esn)[i]; - } - pt->provide_src_names = v; - - if (SCHEME_FALSEP(esnom)) { - pt->provide_nominal_srcs = NULL; - } else { - if (!SCHEME_VECTORP(esnom) || (SCHEME_VEC_SIZE(esnom) != count)) return_NULL(); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - v[i] = SCHEME_VEC_ELS(esnom)[i]; - } - pt->provide_nominal_srcs = v; - } - - if (SCHEME_FALSEP(esph)) - sps = NULL; - else { - if (!SCHEME_VECTORP(esph) || (SCHEME_VEC_SIZE(esph) != count)) return_NULL(); - sps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - sps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esph)[i]); - } - } - pt->provide_src_phases = sps; - - if (SCHEME_FALSEP(einsp)) { - pt->provide_insps = NULL; - } else { - if (!SCHEME_VECTORP(einsp) || (SCHEME_VEC_SIZE(einsp) != count)) return_NULL(); - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - v = MALLOC_N(Scheme_Object *, count); - for (i = 0; i < count; i++) { - if (SCHEME_TRUEP(SCHEME_VEC_ELS(einsp)[i])) { - if (SCHEME_VOIDP(SCHEME_VEC_ELS(einsp)[i])) { - e = cons(scheme_false, insp); - v[i] = e; - } else - v[i] = insp; - } - } - pt->provide_insps = v; - } - } - - count = me->rt->num_provides; - - if (SCHEME_FALSEP(esp)) { - m->provide_protects = NULL; - } else { - if (!SCHEME_VECTORP(esp) || (SCHEME_VEC_SIZE(esp) != count)) return_NULL(); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(esp)[i]); - } - m->provide_protects = ps; - } - - if (SCHEME_FALSEP(eesp)) { - m->et_provide_protects = NULL; - } else { - if (!SCHEME_VECTORP(eesp) || (SCHEME_VEC_SIZE(eesp) != count)) return_NULL(); - ps = MALLOC_N_ATOMIC(char, count); - for (i = 0; i < count; i++) { - ps[i] = SCHEME_TRUEP(SCHEME_VEC_ELS(eesp)[i]); - } - m->et_provide_protects = ps; - } - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - m->et_body = e; - for (i = SCHEME_VEC_SIZE(e); i--; ) { - e = SCHEME_VEC_ELS(m->et_body)[i]; - if (!SCHEME_VECTORP(e)) return_NULL(); - /* SCHEME_VEC_ELS(e)[1] should be code */ - if (!SCHEME_INTP(SCHEME_VEC_ELS(e)[2])) return_NULL(); - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_VEC_ELS(e)[3]), scheme_resolve_prefix_type)) - return_NULL(); - e = SCHEME_VEC_ELS(e)[0]; - if (!SCHEME_SYMBOLP(e)) { - while (SCHEME_PAIRP(e)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(e))) return_NULL(); - e = SCHEME_CDR(e); - } - if (!SCHEME_NULLP(e)) return_NULL(); - } - } - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = SCHEME_CAR(obj); - if (!SCHEME_VECTORP(e)) return_NULL(); - m->body = e; - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->et_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->tt_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - if (scheme_proper_list_length(SCHEME_CAR(obj)) < 0) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - m->dt_requires = e; - if (!check_requires_ok(e)) return_NULL(); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - cnt = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - while (cnt--) { - Scheme_Object *phase; - - if (!SCHEME_PAIRP(obj)) return_NULL(); - phase = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - if (!SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - return_NULL(); - - if (SAME_OBJ(phase, scheme_make_integer(0)) - || SAME_OBJ(phase, scheme_make_integer(1)) - || SAME_OBJ(phase, scheme_make_integer(-1))) - return_NULL(); - - if (!SCHEME_PAIRP(obj)) return_NULL(); - e = scheme_copy_list(SCHEME_CAR(obj)); - if (!check_requires_ok(e)) return_NULL(); - - if (!m->other_requires) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table_equal(); - m->other_requires = ht; - } - scheme_hash_set(m->other_requires, phase, e); - - obj = SCHEME_CDR(obj); - } - - return (Scheme_Object *)m; -} - -Scheme_Object *write_top_level_require(Scheme_Object *o) -{ - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_top_level_require(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_require_form_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} diff --git a/src/racket/src/mzmark.c b/src/racket/src/mzmark.c index af44dec8ad..ec00ff7ed9 100644 --- a/src/racket/src/mzmark.c +++ b/src/racket/src/mzmark.c @@ -2922,8 +2922,16 @@ static int engine_val_FIXUP(void *p, struct NewGC *gc) { #endif /* ENGINE */ +/**********************************************************************/ + #ifdef MARKS_FOR_ENV_C +#endif /* ENV */ + +/**********************************************************************/ + +#ifdef MARKS_FOR_COMPENV_C + static int mark_comp_env_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Scheme_Full_Comp_Env)); @@ -2989,6 +2997,12 @@ static int mark_comp_env_FIXUP(void *p, struct NewGC *gc) { #define mark_comp_env_IS_CONST_SIZE 1 +#endif /* COMPENV */ + +/**********************************************************************/ + +#ifdef MARKS_FOR_RESOLVE_C + static int mark_resolve_info_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Resolve_Info)); @@ -3034,6 +3048,49 @@ static int mark_resolve_info_FIXUP(void *p, struct NewGC *gc) { #define mark_resolve_info_IS_CONST_SIZE 1 +#endif /* RESOLVE */ + +/**********************************************************************/ + +#ifdef MARKS_FOR_SFS_C + +static int mark_sfs_info_SIZE(void *p, struct NewGC *gc) { + return + gcBYTES_TO_WORDS(sizeof(SFS_Info)); +} + +static int mark_sfs_info_MARK(void *p, struct NewGC *gc) { + SFS_Info *i = (SFS_Info *)p; + + gcMARK2(i->max_used, gc); + gcMARK2(i->max_calls, gc); + gcMARK2(i->saved, gc); + + return + gcBYTES_TO_WORDS(sizeof(SFS_Info)); +} + +static int mark_sfs_info_FIXUP(void *p, struct NewGC *gc) { + SFS_Info *i = (SFS_Info *)p; + + gcFIXUP2(i->max_used, gc); + gcFIXUP2(i->max_calls, gc); + gcFIXUP2(i->saved, gc); + + return + gcBYTES_TO_WORDS(sizeof(SFS_Info)); +} + +#define mark_sfs_info_IS_ATOMIC 0 +#define mark_sfs_info_IS_CONST_SIZE 1 + + +#endif /* SFS */ + +/**********************************************************************/ + +#ifdef MARKS_FOR_OPTIMIZE_C + static int mark_optimize_info_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Optimize_Info)); @@ -3077,37 +3134,6 @@ static int mark_optimize_info_FIXUP(void *p, struct NewGC *gc) { #define mark_optimize_info_IS_CONST_SIZE 1 -static int mark_sfs_info_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(SFS_Info)); -} - -static int mark_sfs_info_MARK(void *p, struct NewGC *gc) { - SFS_Info *i = (SFS_Info *)p; - - gcMARK2(i->max_used, gc); - gcMARK2(i->max_calls, gc); - gcMARK2(i->saved, gc); - - return - gcBYTES_TO_WORDS(sizeof(SFS_Info)); -} - -static int mark_sfs_info_FIXUP(void *p, struct NewGC *gc) { - SFS_Info *i = (SFS_Info *)p; - - gcFIXUP2(i->max_used, gc); - gcFIXUP2(i->max_calls, gc); - gcFIXUP2(i->saved, gc); - - return - gcBYTES_TO_WORDS(sizeof(SFS_Info)); -} - -#define mark_sfs_info_IS_ATOMIC 0 -#define mark_sfs_info_IS_CONST_SIZE 1 - - static int mark_once_used_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Scheme_Once_Used)); @@ -3135,7 +3161,7 @@ static int mark_once_used_FIXUP(void *p, struct NewGC *gc) { #define mark_once_used_IS_CONST_SIZE 1 -#endif /* ENV */ +#endif /* OPTIMIZE */ /**********************************************************************/ @@ -3201,6 +3227,12 @@ static int mark_saved_stack_FIXUP(void *p, struct NewGC *gc) { #define mark_saved_stack_IS_CONST_SIZE 1 +#endif /* EVAL */ + +/**********************************************************************/ + +#ifdef MARKS_FOR_VALIDATE_C + static int mark_validate_clearing_SIZE(void *p, struct NewGC *gc) { return gcBYTES_TO_WORDS(sizeof(Validate_Clearing)); @@ -3230,7 +3262,7 @@ static int mark_validate_clearing_FIXUP(void *p, struct NewGC *gc) { #define mark_validate_clearing_IS_CONST_SIZE 1 -#endif /* EVAL */ +#endif /* VALIDATE */ /**********************************************************************/ @@ -5076,9 +5108,9 @@ static int mark_chaperone_FIXUP(void *p, struct NewGC *gc) { /**********************************************************************/ -#ifdef MARKS_FOR_SYNTAX_C +#ifdef MARKS_FOR_COMPILE_C -#endif /* SYNTAX */ +#endif /* COMPILE */ /**********************************************************************/ @@ -5380,7 +5412,7 @@ static int mark_string_convert_FIXUP(void *p, struct NewGC *gc) { /**********************************************************************/ -#ifdef MARKS_FOR_STXOBJ_C +#ifdef MARKS_FOR_SYNTAX_C static int mark_rename_table_SIZE(void *p, struct NewGC *gc) { return @@ -5601,7 +5633,7 @@ static int mark_free_id_info_FIXUP(void *p, struct NewGC *gc) { -#endif /* STXOBJ */ +#endif /* SYNTAX */ /**********************************************************************/ diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index f64be238dd..b25c47388c 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -1175,8 +1175,16 @@ engine_val { END engine; +/**********************************************************************/ + START env; +END env; + +/**********************************************************************/ + +START compenv; + mark_comp_env { mark: Scheme_Full_Comp_Env *e = (Scheme_Full_Comp_Env *)p; @@ -1206,6 +1214,12 @@ mark_comp_env { gcBYTES_TO_WORDS(sizeof(Scheme_Full_Comp_Env)); } +END compenv; + +/**********************************************************************/ + +START resolve; + mark_resolve_info { mark: Resolve_Info *i = (Resolve_Info *)p; @@ -1225,6 +1239,30 @@ mark_resolve_info { gcBYTES_TO_WORDS(sizeof(Resolve_Info)); } +END resolve; + +/**********************************************************************/ + +START sfs; + +mark_sfs_info { + mark: + SFS_Info *i = (SFS_Info *)p; + + gcMARK2(i->max_used, gc); + gcMARK2(i->max_calls, gc); + gcMARK2(i->saved, gc); + + size: + gcBYTES_TO_WORDS(sizeof(SFS_Info)); +} + +END sfs; + +/**********************************************************************/ + +START optimize; + mark_optimize_info { mark: Optimize_Info *i = (Optimize_Info *)p; @@ -1243,18 +1281,6 @@ mark_optimize_info { gcBYTES_TO_WORDS(sizeof(Optimize_Info)); } -mark_sfs_info { - mark: - SFS_Info *i = (SFS_Info *)p; - - gcMARK2(i->max_used, gc); - gcMARK2(i->max_calls, gc); - gcMARK2(i->saved, gc); - - size: - gcBYTES_TO_WORDS(sizeof(SFS_Info)); -} - mark_once_used { mark: Scheme_Once_Used *o = (Scheme_Once_Used *)p; @@ -1265,7 +1291,7 @@ mark_once_used { gcBYTES_TO_WORDS(sizeof(Scheme_Once_Used)); } -END env; +END optimize; /**********************************************************************/ @@ -1294,6 +1320,12 @@ mark_saved_stack { gcBYTES_TO_WORDS(sizeof(Scheme_Saved_Stack)); } +END eval; + +/**********************************************************************/ + +START validate; + mark_validate_clearing { mark: Validate_Clearing *vc = (Validate_Clearing *)p; @@ -1305,7 +1337,7 @@ mark_validate_clearing { gcBYTES_TO_WORDS(sizeof(Validate_Clearing)); } -END eval; +END validate; /**********************************************************************/ @@ -2079,9 +2111,9 @@ END struct; /**********************************************************************/ -START syntax; +START compile; -END syntax; +END compile; /**********************************************************************/ @@ -2211,7 +2243,7 @@ END string; /**********************************************************************/ -START stxobj; +START syntax; mark_rename_table { mark: @@ -2298,7 +2330,7 @@ mark_free_id_info { -END stxobj; +END syntax; /**********************************************************************/ diff --git a/src/racket/src/optimize.c b/src/racket/src/optimize.c new file mode 100644 index 0000000000..4e263851e6 --- /dev/null +++ b/src/racket/src/optimize.c @@ -0,0 +1,5823 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* This file implements bytecode optimzation. + + See "eval.c" for an overview of compilation passes. */ + +#include "schpriv.h" +#include "schrunst.h" +#include "schmach.h" + +#define cons(a,b) scheme_make_pair(a,b) + +#define MAX_PROC_INLINE_SIZE 256 + +struct Optimize_Info +{ + MZTAG_IF_REQUIRED + short flags; + struct Optimize_Info *next; + int original_frame, new_frame; + Scheme_Object *consts; + + /* Propagated up and down the chain: */ + int size, vclock, psize; + short inline_fuel; + char letrec_not_twice, enforce_const, use_psize, has_nonleaf; + Scheme_Hash_Table *top_level_consts; + + /* Set by expression optimization: */ + int single_result, preserves_marks; /* negative means "tentative", due to fixpoint in progress */ + + char **stat_dists; /* (pos, depth) => used? */ + int *sd_depths; + int used_toplevel; + char *use; + + int transitive_use_pos; /* set to pos + 1 when optimizing a letrec-bound procedure */ + mzshort **transitive_use; + int *transitive_use_len; + + Scheme_Object *context; /* for logging */ +}; + +static char *get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok); +static void set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map); +static void merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2); +static int closure_body_size(Scheme_Closure_Data *data, int check_assign, + Optimize_Info *info, int *is_leaf); +static int closure_has_top_level(Scheme_Closure_Data *data); +static int closure_argument_flags(Scheme_Closure_Data *data, int i); + +static int optimize_info_is_ready(Optimize_Info *info, int pos); + +static void optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use); +static Scheme_Object *optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use, + int once_used_ok, int context, int *potential_size); +static void optimize_info_used_top(Optimize_Info *info); + +static void optimize_mutated(Optimize_Info *info, int pos); +static void optimize_produces_flonum(Optimize_Info *info, int pos); +static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated); +static int optimize_is_used(Optimize_Info *info, int pos); +static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos); +static int optimize_is_mutated(Optimize_Info *info, int pos); +static int optimize_is_flonum_arg(Optimize_Info *info, int pos, int depth); +static int optimize_is_flonum_valued(Optimize_Info *info, int pos); +static int env_uses_toplevel(Optimize_Info *frame); +static void env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map); + +static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags); +static int optimize_info_get_shift(Optimize_Info *info, int pos); +static void optimize_info_done(Optimize_Info *info); + +typedef struct Scheme_Once_Used { + Scheme_Object so; + Scheme_Object *expr; + int pos; + int vclock; + + int used; + int delta; + Optimize_Info *info; + + struct Scheme_Once_Used *next; +} Scheme_Once_Used; + +static Scheme_Once_Used *make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev); + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +void scheme_init_optimize() +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif +} + +/*========================================================================*/ +/* utils */ +/*========================================================================*/ + +static int is_current_inspector_call(Scheme_Object *a) +{ + if (SAME_TYPE(SCHEME_TYPE(a), scheme_application_type)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)a; + if (!app->num_args + && SAME_OBJ(app->args[0], scheme_current_inspector_proc)) + return 1; + } + return 0; +} + +static int is_proc_spec_proc(Scheme_Object *p) +{ + Scheme_Type vtype; + + if (SCHEME_PROCP(p)) { + p = scheme_get_or_check_arity(p, -1); + if (SCHEME_INTP(p)) { + return (SCHEME_INT_VAL(p) >= 1); + } else if (SCHEME_STRUCTP(p) + && scheme_is_struct_instance(scheme_arity_at_least, p)) { + p = ((Scheme_Structure *)p)->slots[0]; + if (SCHEME_INTP(p)) + return (SCHEME_INT_VAL(p) >= 1); + } + return 0; + } + + vtype = SCHEME_TYPE(p); + + if (vtype == scheme_unclosed_procedure_type) { + if (((Scheme_Closure_Data *)p)->num_params >= 1) + return 1; + } + + return 0; +} + +static void note_match(int actual, int expected, Optimize_Info *warn_info) +{ + if (!warn_info || (expected == -1)) + return; + + if (actual != expected) { + scheme_log(NULL, + SCHEME_LOG_WARNING, + 0, + "warning%s: optimizer detects %d values produced when %d expected", + scheme_optimize_context_to_string(warn_info->context), + actual, expected); + } +} + +int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, + Optimize_Info *warn_info, int deeper_than) + /* Checks whether the bytecode `o' returns `vals' values with no + side-effects and without pushing and using continuation marks. + -1 for vals means that any return count is ok. + Also used with fully resolved expression by `module' to check + for "functional" bodies. + If warn_info is supplied, complain when a mismatch is detected. */ +{ + Scheme_Type vtype; + + /* FIXME: can overflow the stack */ + + try_again: + + vtype = SCHEME_TYPE(o); + + if ((vtype > _scheme_compiled_values_types_) + || ((vtype == scheme_local_type) + && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ) + && (SCHEME_LOCAL_POS(o) > deeper_than)) + || ((vtype == scheme_local_unbox_type) + && !(SCHEME_GET_LOCAL_FLAGS(o) == SCHEME_LOCAL_CLEAR_ON_READ) + && (SCHEME_LOCAL_POS(o) > deeper_than)) + || (vtype == scheme_unclosed_procedure_type) + || (vtype == scheme_compiled_unclosed_procedure_type) + || (vtype == scheme_case_lambda_sequence_type) + || (vtype == scheme_case_lambda_sequence_type) + || (vtype == scheme_quote_syntax_type) + || (vtype == scheme_compiled_quote_syntax_type)) { + note_match(1, vals, warn_info); + return ((vals == 1) || (vals < 0)); + } + + if (vtype == scheme_toplevel_type) { + note_match(1, vals, warn_info); + if (resolved && ((vals == 1) || (vals < 0))) { + if (SCHEME_TOPLEVEL_FLAGS(o) + & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY)) + return 1; + else + return 0; + } + } + + if (vtype == scheme_compiled_toplevel_type) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + if (SCHEME_TOPLEVEL_FLAGS(o) + & (SCHEME_TOPLEVEL_CONST | SCHEME_TOPLEVEL_READY)) + return 1; + else + return 0; + } + } + + if (vtype == scheme_case_lambda_sequence_type) { + note_match(1, vals, warn_info); + return 1; + } + + if ((vtype == scheme_compiled_quote_syntax_type)) { + note_match(1, vals, warn_info); + return ((vals == 1) || (vals < 0)); + } + + if ((vtype == scheme_branch_type)) { + Scheme_Branch_Rec *b; + b = (Scheme_Branch_Rec *)o; + return (scheme_omittable_expr(b->test, 1, fuel - 1, resolved, warn_info, deeper_than) + && scheme_omittable_expr(b->tbranch, vals, fuel - 1, resolved, warn_info, deeper_than) + && scheme_omittable_expr(b->fbranch, vals, fuel - 1, resolved, warn_info, deeper_than)); + } + +#if 0 + /* We can't do this because a set! to a lexical is turned into + a let_value_type! */ + if ((vtype == scheme_let_value_type)) { + Scheme_Let_Value *lv = (Scheme_Let_Value *)o; + return (scheme_omittable_expr(lv->value, lv->count, fuel - 1, resolved, warn_info, deeper_than) + && scheme_omittable_expr(lv->body, vals, fuel - 1, resolved, warn_info, deeper_than)); + } +#endif + + if ((vtype == scheme_let_one_type)) { + Scheme_Let_One *lo = (Scheme_Let_One *)o; + return (scheme_omittable_expr(lo->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1) + && scheme_omittable_expr(lo->body, vals, fuel - 1, resolved, warn_info, deeper_than + 1)); + } + + if ((vtype == scheme_let_void_type)) { + Scheme_Let_Void *lv = (Scheme_Let_Void *)o; + /* recognize (letrec ([x ]) ...): */ + if (SAME_TYPE(SCHEME_TYPE(lv->body), scheme_let_value_type)) { + Scheme_Let_Value *lv2 = (Scheme_Let_Value *)lv->body; + if ((lv2->count == 1) + && (lv2->position == 0) + && scheme_omittable_expr(lv2->value, 1, fuel - 1, resolved, warn_info, + deeper_than + 1 + lv->count)) { + o = lv2->body; + deeper_than += 1; + } else + o = lv->body; + } else + o = lv->body; + deeper_than += lv->count; + goto try_again; + } + + if ((vtype == scheme_compiled_let_void_type)) { + /* recognize another (let ([x ]) ...) pattern: */ + Scheme_Let_Header *lh = (Scheme_Let_Header *)o; + if ((lh->count == 1) && (lh->num_clauses == 1)) { + if (SAME_TYPE(SCHEME_TYPE(lh->body), scheme_compiled_let_value_type)) { + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; + if (scheme_omittable_expr(lv->value, 1, fuel - 1, resolved, warn_info, deeper_than + 1)) { + o = lv->body; + deeper_than++; + goto try_again; + } + } + } + } + + if ((vtype == scheme_letrec_type)) { + o = ((Scheme_Letrec *)o)->body; + goto try_again; + } + + if ((vtype == scheme_application_type)) { + /* Look for multiple values, or for `make-struct-type'. + (The latter is especially useful to Honu.) */ + Scheme_App_Rec *app = (Scheme_App_Rec *)o; + if ((app->num_args >= 4) && (app->num_args <= 10) + && SAME_OBJ(scheme_make_struct_type_proc, app->args[0])) { + note_match(5, vals, warn_info); + if ((vals == 5) || (vals < 0)) { + /* Look for (make-struct-type sym #f non-neg-int non-neg-int [omitable null]) */ + if (SCHEME_SYMBOLP(app->args[1]) + && SCHEME_FALSEP(app->args[2]) + && SCHEME_INTP(app->args[3]) + && (SCHEME_INT_VAL(app->args[3]) >= 0) + && SCHEME_INTP(app->args[4]) + && (SCHEME_INT_VAL(app->args[4]) >= 0) + && ((app->num_args < 5) + || scheme_omittable_expr(app->args[5], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0))) + && ((app->num_args < 6) + || SCHEME_NULLP(app->args[6])) + && ((app->num_args < 7) + || SCHEME_FALSEP(app->args[7]) + || is_current_inspector_call(app->args[7])) + && ((app->num_args < 8) + || SCHEME_FALSEP(app->args[8]) + || is_proc_spec_proc(app->args[8])) + && ((app->num_args < 9) + || SCHEME_NULLP(app->args[9]))) { + return 1; + } + } + } + /* (values ...) */ + if (SAME_OBJ(scheme_values_func, app->args[0])) { + note_match(app->num_args, vals, warn_info); + if ((app->num_args == vals) || (vals < 0)) { + int i; + for (i = app->num_args; i--; ) { + if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0))) + return 0; + } + return 1; + } + } + /* ({void,list,list*,vector,vector-immutable} ...) */ + if (SAME_OBJ(scheme_void_proc, app->args[0]) + || SAME_OBJ(scheme_list_proc, app->args[0]) + || SAME_OBJ(scheme_list_star_proc, app->args[0]) + || SAME_OBJ(scheme_vector_proc, app->args[0]) + || SAME_OBJ(scheme_vector_immutable_proc, app->args[0])) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + int i; + for (i = app->num_args; i--; ) { + if (!scheme_omittable_expr(app->args[i + 1], 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? app->num_args : 0))) + return 0; + } + return 1; + } + } + if (SCHEME_PRIMP(app->args[0]) + && (SCHEME_PRIM_PROC_FLAGS(app->args[0]) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (app->num_args >= ((Scheme_Primitive_Proc *)app->args[0])->mina) + && (app->num_args <= ((Scheme_Primitive_Proc *)app->args[0])->mu.maxa)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + /* can omit an unsafe op */ + return 1; + } + } + return 0; + } + + if ((vtype == scheme_application2_type)) { + /* ({values,void,list,list*,vector,vector-immutable,box} ) */ + Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; + if (SAME_OBJ(scheme_values_func, app->rator) + || SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator) + || SAME_OBJ(scheme_box_proc, app->rator)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 1 : 0))) + return 1; + } + } + if (SCHEME_PRIMP(app->rator) + && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (1 >= ((Scheme_Primitive_Proc *)app->rator)->mina) + && (1 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + if (scheme_omittable_expr(app->rand, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 1 : 0))) + return 1; + } + } + return 0; + } + + if ((vtype == scheme_application3_type)) { + /* (values ) */ + Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; + if (SAME_OBJ(scheme_values_func, app->rator)) { + note_match(2, vals, warn_info); + if ((vals == 2) || (vals < 0)) { + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0)) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0))) + return 1; + } + } + /* ({void,cons,list,list*,vector,vector-immutable) ) */ + if (SAME_OBJ(scheme_void_proc, app->rator) + || SAME_OBJ(scheme_cons_proc, app->rator) + || SAME_OBJ(scheme_mcons_proc, app->rator) + || SAME_OBJ(scheme_list_proc, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator) + || SAME_OBJ(scheme_vector_proc, app->rator) + || SAME_OBJ(scheme_vector_immutable_proc, app->rator)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0)) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0))) + return 1; + } + } + if (SCHEME_PRIMP(app->rator) + && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (2 >= ((Scheme_Primitive_Proc *)app->rator)->mina) + && (2 <= ((Scheme_Primitive_Proc *)app->rator)->mu.maxa)) { + note_match(1, vals, warn_info); + if ((vals == 1) || (vals < 0)) { + if (scheme_omittable_expr(app->rand1, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0)) + && scheme_omittable_expr(app->rand2, 1, fuel - 1, resolved, warn_info, + deeper_than + (resolved ? 2 : 0))) + return 1; + } + } + } + + return 0; +} + +static int single_valued_noncm_expression(Scheme_Object *expr, int fuel) +/* Non-omittable but single-valued expresions that are not sensitive + to being in tail position. */ +{ + Scheme_Object *rator = NULL; + + switch (SCHEME_TYPE(expr)) { + case scheme_toplevel_type: + return 1; + case scheme_application_type: + rator = ((Scheme_App_Rec *)expr)->args[0]; + break; + case scheme_application2_type: + rator = ((Scheme_App2_Rec *)expr)->rator; + break; + case scheme_application3_type: + rator = ((Scheme_App2_Rec *)expr)->rator; + break; + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *lh = (Scheme_Let_Header *)expr; + Scheme_Compiled_Let_Value *clv; + if ((lh->count == 1) && (lh->num_clauses == 1) && (fuel > 0)) { + clv = (Scheme_Compiled_Let_Value *)lh->body; + return single_valued_noncm_expression(clv->body, fuel - 1); + } + } + break; + } + + if (rator && SCHEME_PRIMP(rator)) { + int opt; + opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; + if (opt >= SCHEME_PRIM_OPT_NONCM) + return 1; + } + + return 0; +} + +int scheme_is_compiled_procedure(Scheme_Object *o, int can_be_closed, int can_be_liftable) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type)) { + if (!can_be_closed || !can_be_liftable) { + Scheme_Closure_Data *data; + data = (Scheme_Closure_Data *)o; + /* Because == 0 is like a constant */ + if (!can_be_closed && !data->closure_size) + return 0; + /* Because procs that reference only globals are lifted: */ + if (!can_be_liftable && (data->closure_size == 1) && closure_has_top_level(data)) + return 0; + } + return 1; + } else + return 0; +} + +/*========================================================================*/ +/* applications, branches, sequences */ +/*========================================================================*/ + +static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_Info *info, int context, int rator_flags); +static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags); +static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimize_Info *info, int context, int rator_flags); + +static Scheme_Object *try_optimize_fold(Scheme_Object *f, Scheme_Object *o, Optimize_Info *info) +{ + if ((SCHEME_PRIMP(f) + && ((((Scheme_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) + == SCHEME_PRIM_OPT_FOLDING)) + || (SCHEME_CLSD_PRIMP(f) + && ((((Scheme_Closed_Primitive_Proc *)f)->pp.flags & SCHEME_PRIM_OPT_MASK) + == SCHEME_PRIM_OPT_FOLDING))) { + Scheme_Object *args; + + switch (SCHEME_TYPE(o)) { + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)o; + int i; + + args = scheme_null; + for (i = app->num_args; i--; ) { + args = scheme_make_pair(app->args[i + 1], args); + } + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; + args = scheme_make_pair(app->rand, scheme_null); + } + break; + case scheme_application3_type: + default: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; + args = scheme_make_pair(app->rand1, + scheme_make_pair(app->rand2, + scheme_null)); + } + break; + } + + return scheme_try_apply(f, args, info->context); + } + + return NULL; +} + +static int estimate_expr_size(Scheme_Object *expr, int sz, int fuel) +{ + Scheme_Type t; + + if (sz > 128) + return sz; + if (fuel < 0) + return sz + 128; + + t = SCHEME_TYPE(expr); + + switch(t) { + case scheme_local_type: + { + sz += 1; + break; + } + case scheme_case_lambda_sequence_type: + { + int max_sz = sz + 1, a_sz; + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr; + int i; + for (i = cl->count; i--; ) { + a_sz = estimate_expr_size(cl->array[i], sz, fuel); + if (a_sz > max_sz) max_sz = a_sz; + } + sz = max_sz; + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; + + sz = estimate_expr_size(app->rator, sz, fuel - 1); + sz = estimate_expr_size(app->rand, sz, fuel - 1); + sz++; + + break; + } + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)expr; + int i; + + for (i = app->num_args + 1; i--; ) { + sz = estimate_expr_size(app->args[i], sz, fuel - 1); + } + sz++; + + break; + } + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; + + sz = estimate_expr_size(app->rator, sz, fuel - 1); + sz = estimate_expr_size(app->rand1, sz, fuel - 1); + sz = estimate_expr_size(app->rand2, sz, fuel - 1); + sz++; + + break; + } + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *head = (Scheme_Let_Header *)expr; + Scheme_Object *body; + Scheme_Compiled_Let_Value *lv; + int i; + + body = head->body; + for (i = head->num_clauses; i--; ) { + lv = (Scheme_Compiled_Let_Value *)body; + sz = estimate_expr_size(lv->value, sz, fuel - 1); + body = lv->body; + sz++; + } + sz = estimate_expr_size(body, sz, fuel - 1); + break; + } + case scheme_sequence_type: + case scheme_begin0_sequence_type: + { + Scheme_Sequence *seq = (Scheme_Sequence *)expr; + int i; + + for (i = seq->count; i--; ) { + sz = estimate_expr_size(seq->array[i], sz, fuel - 1); + } + + break; + } + case scheme_branch_type: + { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr; + + sz = estimate_expr_size(b->test, sz, fuel - 1); + sz = estimate_expr_size(b->tbranch, sz, fuel - 1); + sz = estimate_expr_size(b->fbranch, sz, fuel - 1); + break; + } + case scheme_compiled_unclosed_procedure_type: + { + sz = estimate_expr_size(((Scheme_Closure_Data *)expr)->code, sz, fuel - 1); + sz++; + break; + } + case scheme_compiled_toplevel_type: + case scheme_compiled_quote_syntax_type: + /* FIXME: other syntax types not covered */ + default: + sz += 1; + break; + } + + return sz; +} + +Scheme_Object *scheme_estimate_closure_size(Scheme_Object *e) +{ + int sz; + sz = estimate_expr_size(e, 0, 32); + return scheme_box(scheme_make_integer(sz)); +} + +Scheme_Object *scheme_no_potential_size(Scheme_Object *v) +{ + if (v && SCHEME_BOXP(v)) + return NULL; + else + return v; +} + +static Scheme_Object *apply_inlined(Scheme_Object *p, Scheme_Closure_Data *data, Optimize_Info *info, + int argc, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, + int context, + int nested_count, Scheme_Object *orig, Scheme_Object *le_prev, intptr_t prev_offset) +{ + Scheme_Let_Header *lh; + Scheme_Compiled_Let_Value *lv, *prev = NULL; + Scheme_Object *val; + int i, expected; + int *flags, flag; + Optimize_Info *sub_info; + + expected = data->num_params; + + if (!expected) { + info = optimize_info_add_frame(info, 0, 0, 0); + info->inline_fuel >>= 1; + p = scheme_optimize_expr(p, info, context); + info->next->single_result = info->single_result; + info->next->preserves_marks = info->preserves_marks; + optimize_info_done(info); + + if (le_prev) { + *((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p; + return orig; + } else + return p; + } + + lh = MALLOC_ONE_TAGGED(Scheme_Let_Header); + lh->iso.so.type = scheme_compiled_let_void_type; + lh->count = expected; + lh->num_clauses = expected; + + for (i = 0; i < expected; i++) { + lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); + lv->iso.so.type = scheme_compiled_let_value_type; + lv->count = 1; + lv->position = i; + + if ((i == expected - 1) + && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) { + int j; + Scheme_Object *l = scheme_null; + + for (j = argc; j-- > i; ) { + if (app) + val = app->args[j + 1]; + else if (app3) + val = (j ? app3->rand2 : app3->rand1); + else if (app2) + val = app2->rand; + else + val = scheme_false; + + l = cons(val, l); + } + l = cons(scheme_list_proc, l); + val = scheme_make_application(l); + } else if (app) + val = app->args[i + 1]; + else if (app3) + val = (i ? app3->rand2 : app3->rand1); + else + val = app2->rand; + + if (nested_count) + val = scheme_optimize_shift(val, nested_count, 0); + lv->value = val; + + flag = closure_argument_flags(data, i); + flags = (int *)scheme_malloc_atomic(sizeof(int)); + flags[0] = flag; + lv->flags = flags; + + if (prev) + prev->body = (Scheme_Object *)lv; + else + lh->body = (Scheme_Object *)lv; + prev = lv; + } + + if (prev) + prev->body = p; + else + lh->body = p; + + sub_info = optimize_info_add_frame(info, 0, 0, 0); + sub_info->inline_fuel >>= 1; + + p = scheme_optimize_lets((Scheme_Object *)lh, sub_info, 1, context); + + info->single_result = sub_info->single_result; + info->preserves_marks = sub_info->preserves_marks; + optimize_info_done(sub_info); + + if (le_prev) { + *((Scheme_Object **)(((char *)le_prev) + prev_offset)) = p; + return orig; + } else + return p; +} + +#if 0 +# define LOG_INLINE(x) x +#else +# define LOG_INLINE(x) /*empty*/ +#endif + +Scheme_Object *optimize_for_inline(Optimize_Info *info, Scheme_Object *le, int argc, + Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, + int *_flags, int context, int optimized_rator) +/* If not app, app2, or app3, just return a known procedure, if any, + and do not check arity. */ +{ + int offset = 0, single_use = 0, psize = 0; + Scheme_Object *bad_app = NULL, *prev = NULL, *orig_le = le; + intptr_t prev_offset = 0; + int nested_count = 0, outside_nested = 0, already_opt = optimized_rator; + + if (info->inline_fuel < 0) + return NULL; + + /* Move inside `let' bindings, so we can convert ((let (....) proc) arg ...) + to (let (....) (proc arg ...)) */ + while (optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_let_void_type)) { + Scheme_Let_Header *lh; + int i; + + lh = (Scheme_Let_Header *)le; + prev = le; + prev_offset = (intptr_t)&(((Scheme_Let_Header *)0x0)->body); + le = lh->body; + for (i = 0; i < lh->num_clauses; i++) { + prev = le; + prev_offset = (intptr_t)&(((Scheme_Compiled_Let_Value *)0x0)->body); + le = ((Scheme_Compiled_Let_Value *)le)->body; + } + nested_count += lh->count; + } + + if (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { + /* Found a `((lambda' */ + single_use = 1; + } + + if (!optimized_rator && SAME_TYPE(SCHEME_TYPE(le), scheme_local_type)) { + /* Check for inlining: */ + le = optimize_info_lookup(info, SCHEME_LOCAL_POS(le), &offset, &single_use, 0, 0, &psize); + outside_nested = 1; + already_opt = 1; + } + + if (le) { + while (SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_toplevel_type)) { + single_use = 0; + if (info->top_level_consts) { + int pos; + pos = SCHEME_TOPLEVEL_POS(le); + le = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + if (le && SCHEME_BOXP(le)) { + psize = SCHEME_INT_VAL(SCHEME_BOX_VAL(le)); + le = NULL; + } + if (!le) + break; + outside_nested = 1; + already_opt = 1; + } else + break; + } + } + + if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_case_lambda_sequence_type)) { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)le; + Scheme_Object *cp; + int i, count; + + if (!app && !app2 && !app3) + return le; + + count = cl->count; + for (i = 0; i < count; i++) { + cp = cl->array[i]; + if (SAME_TYPE(SCHEME_TYPE(cp), scheme_compiled_unclosed_procedure_type)) { + Scheme_Closure_Data *data = (Scheme_Closure_Data *)cp; + if ((data->num_params == argc) + || ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) + && (argc + 1 >= data->num_params))) { + le = cp; + break; + } + } else { + scheme_signal_error("internal error: strange case-lambda"); + } + } + if (i >= count) + bad_app = le; + } + + if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { + Scheme_Closure_Data *data = (Scheme_Closure_Data *)le; + int sz; + + if (!app && !app2 && !app3) + return le; + + *_flags = SCHEME_CLOSURE_DATA_FLAGS(data); + + if ((data->num_params == argc) + || ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) + && (argc + 1 >= data->num_params)) + || (!app && !app2 && !app3)) { + int threshold, is_leaf; + + if (!already_opt) { + /* We have an immediate `lambda' that wasn't optimized, yet. + Go optimize it, first. */ + return NULL; + } + + sz = closure_body_size(data, 1, info, &is_leaf); + if (is_leaf) { + /* encourage inlining of leaves: */ + sz >>= 2; + } + threshold = info->inline_fuel * (2 + argc); + + if ((sz >= 0) && (single_use || (sz <= threshold))) { + Optimize_Info *sub_info; + if (nested_count) { + sub_info = optimize_info_add_frame(info, nested_count, nested_count, 0); + sub_info->vclock++; + /* We could propagate bound values in sub_info, but relevant inlining + and propagatation has probably already happened when the rator was + optimized. */ + } else + sub_info = info; + le = scheme_optimize_clone(0, data->code, sub_info, + offset + (outside_nested ? nested_count : 0), + data->num_params); + + if (le) { + LOG_INLINE(fprintf(stderr, "Inline %d[%d]<=%d@%d %d %s\n", sz, is_leaf, threshold, info->inline_fuel, + single_use, data->name ? scheme_write_to_string(data->name, NULL) : "???")); + le = apply_inlined(le, data, sub_info, argc, app, app2, app3, context, + nested_count, orig_le, prev, prev_offset); + if (nested_count) + optimize_info_done(sub_info); + return le; + } else { + LOG_INLINE(fprintf(stderr, "No inline %s\n", data->name ? scheme_write_to_string(data->name, NULL) : "???")); + info->has_nonleaf = 1; + } + } else { + LOG_INLINE(fprintf(stderr, "No fuel %s %d[%d]>%d@%d %d\n", data->name ? scheme_write_to_string(data->name, NULL) : "???", + sz, is_leaf, threshold, + info->inline_fuel, info->use_psize)); + info->has_nonleaf = 1; + } + } else { + /* Issue warning below */ + bad_app = (Scheme_Object *)data; + } + } + + if (le && SCHEME_PRIMP(le)) { + int opt; + opt = ((Scheme_Prim_Proc_Header *)le)->flags & SCHEME_PRIM_OPT_MASK; + if (opt >= SCHEME_PRIM_OPT_NONCM) + *_flags = (CLOS_PRESERVES_MARKS | CLOS_SINGLE_RESULT); + } + + if (le && SCHEME_PROCP(le) && (app || app2 || app3)) { + Scheme_Object *a[1]; + a[0] = le; + if (!scheme_check_proc_arity(NULL, argc, 0, 1, a)) { + bad_app = le; + } + } + + if (psize) { + LOG_INLINE(fprintf(stderr, "Potential inline %d %d\n", psize, info->inline_fuel * (argc + 2))); + if (psize <= (info->inline_fuel * (argc + 2))) + info->psize += psize; + } + + if (!le) + info->has_nonleaf = 1; + + if (bad_app) { + int len; + const char *pname, *context; + pname = scheme_get_proc_name(bad_app, &len, 0); + context = scheme_optimize_context_to_string(info->context); + scheme_log(NULL, + SCHEME_LOG_WARNING, + 0, + "warning%s: optimizer detects procedure incorrectly applied to %d arguments%s%s", + context, + argc, + pname ? ": " : "", + pname ? pname : ""); + } + + return NULL; +} + +static int is_flonum_expression(Scheme_Object *expr, Optimize_Info *info) +{ + if (scheme_expr_produces_flonum(expr)) + return 1; + + if (SAME_TYPE(SCHEME_TYPE(expr), scheme_local_type)) { + if (optimize_is_flonum_valued(info, SCHEME_LOCAL_POS(expr))) + return 1; + } + + return 0; +} + +static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3, + Optimize_Info *info) +{ + Scheme_Object *rator, *rand, *le; + int n, i; + + if (app) { + rator = app->args[0]; + n = app->num_args; + } else if (app2) { + rator = app2->rator; + n = 1; + } else { + rator = app3->rator; + n = 2; + } + + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) { + rator = optimize_reverse(info, SCHEME_LOCAL_POS(rator), 1); + if (rator) { + int offset, single_use; + le = optimize_info_lookup(info, SCHEME_LOCAL_POS(rator), &offset, &single_use, 0, 0, NULL); + if (le && SAME_TYPE(SCHEME_TYPE(le), scheme_compiled_unclosed_procedure_type)) { + Scheme_Closure_Data *data = (Scheme_Closure_Data *)le; + char *map; + int ok; + + map = get_closure_flonum_map(data, n, &ok); + + if (ok) { + for (i = 0; i < n; i++) { + int is_flonum; + + if (app) + rand = app->args[i+1]; + else if (app2) + rand = app2->rand; + else { + if (!i) + rand = app3->rand1; + else + rand = app3->rand2; + } + + is_flonum = is_flonum_expression(rand, info); + if (is_flonum) { + if (!map) { + map = MALLOC_N_ATOMIC(char, n); + memset(map, 1, n); + memset(map, 0, i); + } + } + if (map && !is_flonum) + map[i] = 0; + } + + set_closure_flonum_map(data, map); + } + } + } + } +} + +char *scheme_optimize_context_to_string(Scheme_Object *context) +{ + if (context) { + Scheme_Object *mod, *func; + const char *ctx, *prefix, *mctx, *mprefix; + char *all; + int clen, plen, mclen, mplen, len; + + if (SCHEME_PAIRP(context)) { + func = SCHEME_CAR(context); + mod = SCHEME_CDR(context); + } else if (SAME_TYPE(SCHEME_TYPE(context), scheme_module_type)) { + func = scheme_false; + mod = context; + } else { + func = context; + mod = scheme_false; + } + + if (SAME_TYPE(SCHEME_TYPE(func), scheme_compiled_unclosed_procedure_type)) { + Scheme_Object *name; + + name = ((Scheme_Closure_Data *)func)->name; + if (name) { + if (SCHEME_VECTORP(name)) { + Scheme_Object *port; + int print_width = 1024; + intptr_t plen; + + port = scheme_make_byte_string_output_port(); + + scheme_write_proc_context(port, print_width, + SCHEME_VEC_ELS(name)[0], + SCHEME_VEC_ELS(name)[1], SCHEME_VEC_ELS(name)[2], + SCHEME_VEC_ELS(name)[3], SCHEME_VEC_ELS(name)[4], + SCHEME_TRUEP(SCHEME_VEC_ELS(name)[6])); + + ctx = scheme_get_sized_byte_string_output(port, &plen); + prefix = " in: "; + } else { + ctx = scheme_get_proc_name(func, &len, 0); + prefix = " in: "; + } + } else { + ctx = ""; + prefix = ""; + } + } else { + ctx = ""; + prefix = ""; + } + + if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_type)) { + mctx = scheme_display_to_string(((Scheme_Module *)mod)->modsrc, NULL); + mprefix = " in module: "; + } else { + mctx = ""; + mprefix = ""; + } + + clen = strlen(ctx); + plen = strlen(prefix); + mclen = strlen(mctx); + mplen = strlen(mprefix); + + if (!clen && !mclen) + return ""; + + all = scheme_malloc_atomic(clen + plen + mclen + mplen + 1); + memcpy(all, prefix, plen); + memcpy(all + plen, ctx, clen); + memcpy(all + plen + clen, mprefix, mplen); + memcpy(all + plen + clen + mplen, mctx, mclen); + all[clen + plen + mclen + mplen] = 0; + return all; + } else + return ""; +} + +static void reset_rator(Scheme_Object *app, Scheme_Object *a) +{ + switch (SCHEME_TYPE(app)) { + case scheme_application_type: + ((Scheme_App_Rec *)app)->args[0] = a; + break; + case scheme_application2_type: + ((Scheme_App2_Rec *)app)->rator = a; + break; + case scheme_application3_type: + ((Scheme_App3_Rec *)app)->rator = a; + break; + } +} + +static Scheme_Object *check_app_let_rator(Scheme_Object *app, Scheme_Object *rator, Optimize_Info *info, + int argc, int context) +{ + /* Convert ((let (....) E) arg ...) to (let (....) (E arg ...)), in case + the `let' is immediately apparent. We check for this pattern again + in optimize_for_inline() after optimizing a rator. */ + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_compiled_let_void_type)) { + Scheme_Let_Header *head = (Scheme_Let_Header *)rator; + Scheme_Compiled_Let_Value *clv; + int i; + + /* Handle ((let ([f ...]) f) arg ...) specially, so we can + adjust the flags for `f': */ + if ((head->count == 1) && (head->num_clauses == 1)) { + clv = (Scheme_Compiled_Let_Value *)head->body; + rator = clv->body; + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type) + && (SCHEME_LOCAL_POS(rator) == 0) + && scheme_is_compiled_procedure(clv->value, 1, 1)) { + + reset_rator(app, scheme_false); + app = scheme_optimize_shift(app, 1, 0); + reset_rator(app, scheme_make_local(scheme_local_type, 0, 0)); + + clv->body = app; + + if (clv->flags[0] & SCHEME_WAS_APPLIED_EXCEPT_ONCE) { + clv->flags[0] -= SCHEME_WAS_APPLIED_EXCEPT_ONCE; + clv->flags[0] |= SCHEME_WAS_ONLY_APPLIED; + } + + return scheme_optimize_expr((Scheme_Object *)head, info, context); + } + } + + clv = NULL; + rator = head->body; + for (i = head->num_clauses; i--; ) { + clv = (Scheme_Compiled_Let_Value *)rator; + rator = clv->body; + } + + reset_rator(app, scheme_false); + app = scheme_optimize_shift(app, head->count, 0); + reset_rator(app, rator); + + if (clv) + clv->body = app; + else + head->body = app; + + return scheme_optimize_expr((Scheme_Object *)head, info, context); + } + + return NULL; +} + +static int purely_functional_primitive(Scheme_Object *rator, int n) +{ + if (SCHEME_PRIMP(rator) + && (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) + && (n >= ((Scheme_Primitive_Proc *)rator)->mina) + && (n <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)) + return 1; + + if (SAME_OBJ(scheme_void_proc, rator) + || SAME_OBJ(scheme_list_proc, rator) + || (SAME_OBJ(scheme_cons_proc, rator) && (n == 2)) + || SAME_OBJ(scheme_list_star_proc, rator) + || SAME_OBJ(scheme_vector_proc, rator) + || SAME_OBJ(scheme_vector_immutable_proc, rator) + || (SAME_OBJ(scheme_box_proc, rator) && (n == 1))) + return 1; + + return 0; +} + +#define IS_NAMED_PRIM(p, nm) (!strcmp(((Scheme_Primitive_Proc *)p)->name, nm)) + +int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_mode) +/* In rotate mode, we really want to know whether any argument wants to be lifted out. */ +{ + if (SCHEME_PRIMP(rator)) { + if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) { + if (IS_NAMED_PRIM(rator, "unsafe-flabs") + || IS_NAMED_PRIM(rator, "unsafe-flsqrt") + || IS_NAMED_PRIM(rator, "unsafe-fl+") + || IS_NAMED_PRIM(rator, "unsafe-fl-") + || IS_NAMED_PRIM(rator, "unsafe-fl*") + || IS_NAMED_PRIM(rator, "unsafe-fl/") + || IS_NAMED_PRIM(rator, "unsafe-fl<") + || IS_NAMED_PRIM(rator, "unsafe-fl<=") + || IS_NAMED_PRIM(rator, "unsafe-fl=") + || IS_NAMED_PRIM(rator, "unsafe-fl>") + || IS_NAMED_PRIM(rator, "unsafe-fl>=") + || IS_NAMED_PRIM(rator, "unsafe-flmin") + || IS_NAMED_PRIM(rator, "unsafe-flmax") + || (!rotate_mode && IS_NAMED_PRIM(rator, "unsafe-fl->fx")) + || (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) + || (rotate_mode && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) + return 1; + } else if (SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { + if (!rotate_mode) { + if (IS_NAMED_PRIM(rator, "flabs") + || IS_NAMED_PRIM(rator, "flsqrt") + || IS_NAMED_PRIM(rator, "fltruncate") + || IS_NAMED_PRIM(rator, "flround") + || IS_NAMED_PRIM(rator, "flfloor") + || IS_NAMED_PRIM(rator, "flceiling") + || IS_NAMED_PRIM(rator, "flsin") + || IS_NAMED_PRIM(rator, "flcos") + || IS_NAMED_PRIM(rator, "fltan") + || IS_NAMED_PRIM(rator, "flasin") + || IS_NAMED_PRIM(rator, "flacos") + || IS_NAMED_PRIM(rator, "flatan") + || IS_NAMED_PRIM(rator, "fllog") + || IS_NAMED_PRIM(rator, "flexp") + || IS_NAMED_PRIM(rator, "fl+") + || IS_NAMED_PRIM(rator, "fl-") + || IS_NAMED_PRIM(rator, "fl*") + || IS_NAMED_PRIM(rator, "fl/") + || IS_NAMED_PRIM(rator, "fl<") + || IS_NAMED_PRIM(rator, "fl<=") + || IS_NAMED_PRIM(rator, "fl=") + || IS_NAMED_PRIM(rator, "fl>") + || IS_NAMED_PRIM(rator, "flmin") + || IS_NAMED_PRIM(rator, "flmax")) + return 1; + } + if ((rotate_mode || (argpos == 2)) + && IS_NAMED_PRIM(rator, "unsafe-flvector-set!")) + return 1; + if (!rotate_mode && (argpos == 2) + && IS_NAMED_PRIM(rator, "flvector-set!")) + return 1; + } + } + + return 0; +} + +static int produces_unboxed(Scheme_Object *rator, int *non_fl_args, int argc, int for_args) +{ + if (SCHEME_PRIMP(rator)) { + if (SCHEME_PRIM_PROC_FLAGS(rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL) { + if (((argc == 1) + && (IS_NAMED_PRIM(rator, "unsafe-flabs") + || IS_NAMED_PRIM(rator, "unsafe-flsqrt") + || IS_NAMED_PRIM(rator, "unsafe-flreal-part") + || IS_NAMED_PRIM(rator, "unsafe-flimag-part"))) + || ((argc == 2) + && (IS_NAMED_PRIM(rator, "unsafe-fl+") + || IS_NAMED_PRIM(rator, "unsafe-fl-") + || IS_NAMED_PRIM(rator, "unsafe-fl*") + || IS_NAMED_PRIM(rator, "unsafe-fl/") + || IS_NAMED_PRIM(rator, "unsafe-flmin") + || IS_NAMED_PRIM(rator, "unsafe-flmax") + || (for_args + && (IS_NAMED_PRIM(rator, "unsafe-fl<") + || IS_NAMED_PRIM(rator, "unsafe-fl<=") + || IS_NAMED_PRIM(rator, "unsafe-fl=") + || IS_NAMED_PRIM(rator, "unsafe-fl>") + || IS_NAMED_PRIM(rator, "unsafe-fl>=")))))) + return 1; + if (((argc == 2) && IS_NAMED_PRIM(rator, "unsafe-flvector-ref")) + || ((argc == 1) && IS_NAMED_PRIM(rator, "unsafe-fx->fl"))) { + if (non_fl_args) *non_fl_args = 1; + return 1; + } + } else if ((argc == 1) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { + if (IS_NAMED_PRIM(rator, "flabs") + || IS_NAMED_PRIM(rator, "flsqrt") + || IS_NAMED_PRIM(rator, "fltruncate") + || IS_NAMED_PRIM(rator, "flround") + || IS_NAMED_PRIM(rator, "flfloor") + || IS_NAMED_PRIM(rator, "flceiling") + || IS_NAMED_PRIM(rator, "flsin") + || IS_NAMED_PRIM(rator, "flcos") + || IS_NAMED_PRIM(rator, "fltan") + || IS_NAMED_PRIM(rator, "flasin") + || IS_NAMED_PRIM(rator, "flacos") + || IS_NAMED_PRIM(rator, "flatan") + || IS_NAMED_PRIM(rator, "fllog") + || IS_NAMED_PRIM(rator, "flexp") + || IS_NAMED_PRIM(rator, "flimag-part") + || IS_NAMED_PRIM(rator, "flreal-part")) + return 1; + if (IS_NAMED_PRIM(rator, "->fl")) { + if (non_fl_args) *non_fl_args = 1; + return 1; + } + } else if ((argc ==2) && SCHEME_PRIM_IS_SOMETIMES_INLINED(rator)) { + if (IS_NAMED_PRIM(rator, "flabs") + || IS_NAMED_PRIM(rator, "flsqrt") + || IS_NAMED_PRIM(rator, "fl+") + || IS_NAMED_PRIM(rator, "fl-") + || IS_NAMED_PRIM(rator, "fl*") + || IS_NAMED_PRIM(rator, "fl/") + || IS_NAMED_PRIM(rator, "flmin") + || IS_NAMED_PRIM(rator, "flmax") + || (for_args + && (IS_NAMED_PRIM(rator, "fl<") + || IS_NAMED_PRIM(rator, "fl<=") + || IS_NAMED_PRIM(rator, "fl=") + || IS_NAMED_PRIM(rator, "fl>") + || IS_NAMED_PRIM(rator, "fl>=")))) + return 1; + if (IS_NAMED_PRIM(rator, "flvector-ref")) { + if (non_fl_args) *non_fl_args = 1; + return 1; + } + } + } + + return 0; +} + +static int is_unboxed_argument(Scheme_Object *rand, int fuel, Optimize_Info *info, int lifted) +{ + if (fuel > 0) { + switch (SCHEME_TYPE(rand)) { + case scheme_local_type: + { + /* Ok if not mutable */ + int pos = SCHEME_LOCAL_POS(rand); + if (pos < lifted) + return 1; + else if (!optimize_is_mutated(info, pos - lifted)) + return 1; + } + break; + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)rand; + int non_fl_args = 0; + if (produces_unboxed(app->args[0], &non_fl_args, app->num_args, 1)) { + int i; + for (i = app->num_args; i--; ) { + fuel--; + if (!is_unboxed_argument(app->args[i+1], fuel, info, lifted)) + return 0; + } + return 1; + } + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)rand; + int non_fl_args = 0; + if (produces_unboxed(app->rator, &non_fl_args, 1, 1)) { + if (is_unboxed_argument(app->rand, fuel - 1, info, lifted)) + return 1; + } + } + break; + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)rand; + int non_fl_args = 0; + if (produces_unboxed(app->rator, &non_fl_args, 2, 1)) { + if (is_unboxed_argument(app->rand1, fuel - 1, info, lifted) + && is_unboxed_argument(app->rand2, fuel - 2, info, lifted)) + return 1; + } + } + break; + default: + if (SCHEME_TYPE(rand) > _scheme_compiled_values_types_) + return 1; + break; + } + } + + return 0; +} + +int scheme_expr_produces_flonum(Scheme_Object *expr) +{ + while (1) { + switch (SCHEME_TYPE(expr)) { + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)expr; + return produces_unboxed(app->args[0], NULL, app->num_args, 0); + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; + return produces_unboxed(app->rator, NULL, 1, 0); + } + break; + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; + return produces_unboxed(app->rator, NULL, 2, 0); + } + break; + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *lh = (Scheme_Let_Header *)expr; + int i; + expr = lh->body; + for (i = 0; i < lh->num_clauses; i++) { + expr = ((Scheme_Compiled_Let_Value *)expr)->body; + } + /* check expr again */ + } + break; + default: + if (SCHEME_FLOATP(expr)) + return 1; + return 0; + } + } +} + +static Scheme_Object *check_unbox_rotation(Scheme_Object *_app, Scheme_Object *rator, int count, Optimize_Info *info) +{ + Scheme_Object *result = _app, *rand, *new_rand; + Scheme_Let_Header *inner_head = NULL; + Scheme_Compiled_Let_Value *inner = NULL; + int i, lifted = 0; + + if (scheme_wants_flonum_arguments(rator, 0, 1)) { + for (i = 0; i < count; i++) { + if (count == 1) + rand = ((Scheme_App2_Rec *)_app)->rand; + else if (count == 2) { + if (i == 0) + rand = ((Scheme_App3_Rec *)_app)->rand1; + else + rand = ((Scheme_App3_Rec *)_app)->rand2; + } else + rand = ((Scheme_App_Rec *)_app)->args[i + 1]; + + if (!is_unboxed_argument(rand, 32, info, lifted)) { + int delta; + + if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_let_void_type)) { + /* Rotate ( (let* ([x ]...) )) + to (let* ([x ]...) ( )) */ + Scheme_Let_Header *top_head = (Scheme_Let_Header *)rand, *head; + Scheme_Compiled_Let_Value *clv, *prev; + Scheme_Object *e; + int i; + + top_head = head = (Scheme_Let_Header *)rand; + prev = NULL; + e = rand; + delta = 0; + while (SAME_TYPE(SCHEME_TYPE(e), scheme_compiled_let_void_type)) { + head = (Scheme_Let_Header *)e; + delta += head->count; + prev = NULL; + + clv = (Scheme_Compiled_Let_Value *)head->body; + prev = NULL; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + prev = clv; + } + e = (Scheme_Object *)clv; + } + + if (prev) + new_rand = prev->body; + else + new_rand = head->body; + + if (inner) + inner->body = (Scheme_Object *)top_head; + else if (inner_head) + inner_head->body = (Scheme_Object *)top_head; + else + result = (Scheme_Object *)top_head; + + inner = prev; + inner_head = head; + } else { + /* Rotate ( ) to + (let ([x ]) ( x)) */ + Scheme_Let_Header *head; + Scheme_Compiled_Let_Value *lv; + int *flags; + + head = MALLOC_ONE_TAGGED(Scheme_Let_Header); + head->iso.so.type = scheme_compiled_let_void_type; + head->count = 1; + head->num_clauses = 1; + + lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); + lv->iso.so.type = scheme_compiled_let_value_type; + lv->count = 1; + lv->position = 0; + lv->value = rand; + + flags = (int *)scheme_malloc_atomic(sizeof(int)); + flags[0] = (SCHEME_WAS_USED | (1 << SCHEME_USE_COUNT_SHIFT)); + if (scheme_wants_flonum_arguments(rator, i, 0)) + flags[0] |= SCHEME_WAS_FLONUM_ARGUMENT; + lv->flags = flags; + + head->body = (Scheme_Object *)lv; + + new_rand = scheme_make_local(scheme_local_type, 0, 0); + + if (inner) + inner->body = (Scheme_Object *)head; + else if (inner_head) + inner_head->body = (Scheme_Object *)head; + else + result = (Scheme_Object *)head; + + inner = lv; + inner_head = head; + + delta = 1; + } + + if (delta) { + lifted += delta; + if (count == 1) + ((Scheme_App2_Rec *)_app)->rand = scheme_false; + else if (count == 2) { + if (i == 0) + ((Scheme_App3_Rec *)_app)->rand1 = scheme_false; + else + ((Scheme_App3_Rec *)_app)->rand2 = scheme_false; + } else + ((Scheme_App_Rec *)_app)->args[i + 1] = scheme_false; + + _app = scheme_optimize_shift(_app, delta, 0); + } + + if (count == 1) + ((Scheme_App2_Rec *)_app)->rand = new_rand; + else if (count == 2) { + if (i == 0) + ((Scheme_App3_Rec *)_app)->rand1 = new_rand; + else + ((Scheme_App3_Rec *)_app)->rand2 = new_rand; + } else + ((Scheme_App_Rec *)_app)->args[i + 1] = new_rand; + + if (inner) + inner->body = _app; + else + inner_head->body = _app; + } + } + } + + return result; +} + +static Scheme_Object *finish_optimize_app(Scheme_Object *o, Optimize_Info *info, int context, int rator_flags) +{ + switch(SCHEME_TYPE(o)) { + case scheme_application_type: + return finish_optimize_application((Scheme_App_Rec *)o, info, context, rator_flags); + case scheme_application2_type: + return finish_optimize_application2((Scheme_App2_Rec *)o, info, context, rator_flags); + case scheme_application3_type: + return finish_optimize_application3((Scheme_App3_Rec *)o, info, context, rator_flags); + default: + return o; /* may be a constant due to constant-folding */ + } +} + +static Scheme_Object *direct_apply(Scheme_Object *expr, Scheme_Object *rator, Scheme_Object *last_rand) +{ + if (SAME_OBJ(rator, scheme_apply_proc)) { + switch(SCHEME_TYPE(last_rand)) { + case scheme_application_type: + rator = ((Scheme_App_Rec *)last_rand)->args[0]; + break; + case scheme_application2_type: + rator = ((Scheme_App2_Rec *)last_rand)->rator; + break; + case scheme_application3_type: + rator = ((Scheme_App3_Rec *)last_rand)->rator; + break; + case scheme_pair_type: + if (scheme_is_list(last_rand)) + rator = scheme_list_proc; + else + rator = NULL; + break; + case scheme_null_type: + rator = scheme_list_proc; + break; + default: + rator = NULL; + break; + } + + if (rator && SAME_OBJ(rator, scheme_list_proc)) { + /* Convert (apply f arg1 ... (list arg2 ...)) + to (f arg1 ... arg2 ...) */ + Scheme_Object *l = scheme_null; + int i; + + switch(SCHEME_TYPE(last_rand)) { + case scheme_application_type: + for (i = ((Scheme_App_Rec *)last_rand)->num_args; i--; ) { + l = scheme_make_pair(((Scheme_App_Rec *)last_rand)->args[i+1], l); + } + break; + case scheme_application2_type: + l = scheme_make_pair(((Scheme_App2_Rec *)last_rand)->rand, l); + break; + case scheme_application3_type: + l = scheme_make_pair(((Scheme_App3_Rec *)last_rand)->rand2, l); + l = scheme_make_pair(((Scheme_App3_Rec *)last_rand)->rand1, l); + break; + case scheme_pair_type: + l = last_rand; + break; + case scheme_null_type: + l = scheme_null; + break; + } + + switch(SCHEME_TYPE(expr)) { + case scheme_application_type: + for (i = ((Scheme_App_Rec *)expr)->num_args - 1; i--; ) { + l = scheme_make_pair(((Scheme_App_Rec *)expr)->args[i+1], l); + } + break; + default: + case scheme_application3_type: + l = scheme_make_pair(((Scheme_App3_Rec *)expr)->rand1, l); + break; + } + + return scheme_make_application(l); + } + } + + return NULL; +} + +static Scheme_Object *optimize_application(Scheme_Object *o, Optimize_Info *info, int context) +{ + Scheme_Object *le; + Scheme_App_Rec *app; + int i, n, rator_flags = 0, sub_context = 0; + + app = (Scheme_App_Rec *)o; + + /* Check for (apply ... (list ...)) early: */ + le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args]); + if (le) return scheme_optimize_expr(le, info, context); + + le = check_app_let_rator(o, app->args[0], info, app->num_args, context); + if (le) return le; + + n = app->num_args + 1; + + for (i = 0; i < n; i++) { + if (!i) { + le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 0); + if (le) + return le; + } + + sub_context = 0; + if ((i > 0) && scheme_wants_flonum_arguments(app->args[0], i - 1, 0)) + sub_context = OPT_CONTEXT_FLONUM_ARG; + + le = scheme_optimize_expr(app->args[i], info, sub_context); + app->args[i] = le; + + if (!i) { + /* Maybe found "((lambda" after optimizing; try again */ + le = optimize_for_inline(info, app->args[i], n - 1, app, NULL, NULL, &rator_flags, context, 1); + if (le) + return le; + } + } + + /* Check for (apply ... (list ...)) after some optimizations: */ + le = direct_apply((Scheme_Object *)app, app->args[0], app->args[app->num_args]); + if (le) return finish_optimize_app(le, info, context, rator_flags); + + return finish_optimize_application(app, info, context, rator_flags); +} + +static Scheme_Object *finish_optimize_application(Scheme_App_Rec *app, Optimize_Info *info, int context, int rator_flags) +{ + Scheme_Object *le; + int all_vals = 1, i; + + for (i = app->num_args; i--; ) { + if (SCHEME_TYPE(app->args[i+1]) < _scheme_compiled_values_types_) + all_vals = 0; + } + + info->size += 1; + if (!purely_functional_primitive(app->args[0], app->num_args)) + info->vclock += 1; + + if (all_vals) { + le = try_optimize_fold(app->args[0], (Scheme_Object *)app, info); + if (le) + return le; + } + + info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); + info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); + if (rator_flags & CLOS_RESULT_TENTATIVE) { + info->preserves_marks = -info->preserves_marks; + info->single_result = -info->single_result; + } + + if (!app->num_args && SAME_OBJ(app->args[0], scheme_list_proc)) + return scheme_null; + + register_flonum_argument_types(app, NULL, NULL, info); + + return check_unbox_rotation((Scheme_Object *)app, app->args[0], app->num_args, info); +} + +static Scheme_Object *lookup_constant_proc(Optimize_Info *info, Scheme_Object *rand) +{ + Scheme_Object *c = NULL; + + if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(rand))) + c = rand; + if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) { + int offset; + Scheme_Object *expr; + expr = optimize_reverse(info, SCHEME_LOCAL_POS(rand), 0); + c = optimize_info_lookup(info, SCHEME_LOCAL_POS(expr), &offset, NULL, 0, 0, NULL); + } + if (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_toplevel_type)) { + if (info->top_level_consts) { + int pos; + + while (1) { + pos = SCHEME_TOPLEVEL_POS(rand); + c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + c = scheme_no_potential_size(c); + if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type)) + rand = c; + else + break; + } + } + } + + if (c && SAME_TYPE(scheme_noninline_proc_type, SCHEME_TYPE(c))) { + c = SCHEME_BOX_VAL(c); + + while (SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_let_void_type)) { + /* This must be (let ([x ]) ); see scheme_is_statically_proc() */ + Scheme_Let_Header *lh = (Scheme_Let_Header *)c; + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; + c = lv->body; + } + } + + if (c && (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(c)) + || SAME_TYPE(scheme_case_lambda_sequence_type, SCHEME_TYPE(c)))) + return c; + + return NULL; +} + +static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *info, int context) +{ + Scheme_App2_Rec *app; + Scheme_Object *le; + int rator_flags = 0, sub_context = 0; + + app = (Scheme_App2_Rec *)o; + + le = check_app_let_rator(o, app->rator, info, 1, context); + if (le) return le; + + le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 0); + if (le) + return le; + + le = scheme_optimize_expr(app->rator, info, sub_context); + app->rator = le; + + { + /* Maybe found "((lambda" after optimizing; try again */ + le = optimize_for_inline(info, app->rator, 1, NULL, app, NULL, &rator_flags, context, 1); + if (le) + return le; + } + + if (scheme_wants_flonum_arguments(app->rator, 0, 0)) + sub_context |= OPT_CONTEXT_FLONUM_ARG; + + le = scheme_optimize_expr(app->rand, info, sub_context); + app->rand = le; + + return finish_optimize_application2(app, info, context, rator_flags); +} + +static Scheme_Object *finish_optimize_application2(Scheme_App2_Rec *app, Optimize_Info *info, int context, int rator_flags) +{ + Scheme_Object *le; + + info->size += 1; + + if (SCHEME_TYPE(app->rand) > _scheme_compiled_values_types_) { + le = try_optimize_fold(app->rator, (Scheme_Object *)app, info); + if (le) + return le; + } + + if (SAME_OBJ(scheme_procedure_p_proc, app->rator)) { + if (lookup_constant_proc(info, app->rand)) { + info->preserves_marks = 1; + info->single_result = 1; + return scheme_true; + } + } + + if ((SAME_OBJ(scheme_values_func, app->rator) + || SAME_OBJ(scheme_list_star_proc, app->rator)) + && (scheme_omittable_expr(app->rand, 1, -1, 0, info, -1) + || single_valued_noncm_expression(app->rand, 5))) { + info->preserves_marks = 1; + info->single_result = 1; + return app->rand; + } + + if (!purely_functional_primitive(app->rator, 1)) + info->vclock += 1; + + info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); + info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); + if (rator_flags & CLOS_RESULT_TENTATIVE) { + info->preserves_marks = -info->preserves_marks; + info->single_result = -info->single_result; + } + + /* Check for things like (cXr (cons X Y)): */ + if (SCHEME_PRIMP(app->rator) + && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNARY_INLINED)) { + Scheme_Object *rand, *inside = NULL, *alt = NULL; + + rand = app->rand; + + /* We can go inside a `let', which is useful in case the argument + was a function call that has been inlined. */ + while (SAME_TYPE(SCHEME_TYPE(rand), scheme_compiled_let_void_type)) { + Scheme_Let_Header *head = (Scheme_Let_Header *)rand; + int i; + inside = rand; + rand = head->body; + for (i = head->num_clauses; i--; ) { + inside = rand; + rand = ((Scheme_Compiled_Let_Value *)rand)->body; + } + } + + if (SAME_TYPE(SCHEME_TYPE(rand), scheme_application2_type)) { + Scheme_App2_Rec *app2 = (Scheme_App2_Rec *)rand; + if (SAME_OBJ(scheme_list_proc, app2->rator)) { + if (IS_NAMED_PRIM(app->rator, "car")) { + /* (car (list X)) */ + if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1) + || single_valued_noncm_expression(app2->rand, 5)) { + alt = app2->rand; + } + } else if (IS_NAMED_PRIM(app->rator, "cdr")) { + /* (cdr (list X)) */ + if (scheme_omittable_expr(app2->rand, 1, 5, 0, NULL, -1)) + alt = scheme_null; + } + } + } else if (SAME_TYPE(SCHEME_TYPE(rand), scheme_application3_type)) { + Scheme_App3_Rec *app3 = (Scheme_App3_Rec *)rand; + if (IS_NAMED_PRIM(app->rator, "car")) { + if (SAME_OBJ(scheme_cons_proc, app3->rator) + || SAME_OBJ(scheme_list_proc, app3->rator) + || SAME_OBJ(scheme_list_star_proc, app3->rator)) { + /* (car ({cons|list|cdr} X Y)) */ + if ((scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1) + || single_valued_noncm_expression(app3->rand1, 5)) + && scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1)) { + alt = app3->rand1; + } + } + } else if (IS_NAMED_PRIM(app->rator, "cdr")) { + /* (car (cons X Y)) */ + if (SAME_OBJ(scheme_cons_proc, app3->rator)) { + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1) + || single_valued_noncm_expression(app3->rand2, 5)) + && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1)) { + alt = app3->rand2; + } + } + } else if (IS_NAMED_PRIM(app->rator, "cadr")) { + if (SAME_OBJ(scheme_list_proc, app3->rator)) { + /* (cadr (list X Y)) */ + if ((scheme_omittable_expr(app3->rand2, 1, 5, 0, NULL, -1) + || single_valued_noncm_expression(app3->rand2, 5)) + && scheme_omittable_expr(app3->rand1, 1, 5, 0, NULL, -1)) { + alt = app3->rand2; + } + } + } + } + + if (alt) { + if (inside) { + if (SAME_TYPE(SCHEME_TYPE(inside), scheme_compiled_let_void_type)) + ((Scheme_Let_Header *)inside)->body = alt; + else + ((Scheme_Compiled_Let_Value *)inside)->body = alt; + return app->rand; + } + return alt; + } + } + + register_flonum_argument_types(NULL, app, NULL, info); + + return check_unbox_rotation((Scheme_Object *)app, app->rator, 1, info); +} + +static Scheme_Object *optimize_application3(Scheme_Object *o, Optimize_Info *info, int context) +{ + Scheme_App3_Rec *app; + Scheme_Object *le; + int rator_flags = 0, sub_context = 0; + + app = (Scheme_App3_Rec *)o; + + /* Check for (apply ... (list ...)) early: */ + le = direct_apply((Scheme_Object *)app, app->rator, app->rand2); + if (le) return scheme_optimize_expr(le, info, context); + + le = check_app_let_rator(o, app->rator, info, 2, context); + if (le) return le; + + le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 0); + if (le) + return le; + + le = scheme_optimize_expr(app->rator, info, sub_context); + app->rator = le; + + { + /* Maybe found "((lambda" after optimizing; try again */ + le = optimize_for_inline(info, app->rator, 2, NULL, NULL, app, &rator_flags, context, 1); + if (le) + return le; + } + + /* 1st arg */ + + if (scheme_wants_flonum_arguments(app->rator, 0, 0)) + sub_context |= OPT_CONTEXT_FLONUM_ARG; + + le = scheme_optimize_expr(app->rand1, info, sub_context); + app->rand1 = le; + + /* 2nd arg */ + + if (scheme_wants_flonum_arguments(app->rator, 1, 0)) + sub_context |= OPT_CONTEXT_FLONUM_ARG; + else + sub_context &= ~OPT_CONTEXT_FLONUM_ARG; + + le = scheme_optimize_expr(app->rand2, info, sub_context); + app->rand2 = le; + + /* Check for (apply ... (list ...)) after some optimizations: */ + le = direct_apply((Scheme_Object *)app, app->rator, app->rand2); + if (le) return finish_optimize_app(le, info, context, rator_flags); + + return finish_optimize_application3(app, info, context, rator_flags); +} + +static Scheme_Object *finish_optimize_application3(Scheme_App3_Rec *app, Optimize_Info *info, int context, int rator_flags) +{ + Scheme_Object *le; + int all_vals = 1; + + info->size += 1; + + if (SCHEME_TYPE(app->rand1) < _scheme_compiled_values_types_) + all_vals = 0; + if (SCHEME_TYPE(app->rand2) < _scheme_compiled_values_types_) + all_vals = 0; + + + if (all_vals) { + le = try_optimize_fold(app->rator, (Scheme_Object *)app, info); + if (le) + return le; + } + + if (!purely_functional_primitive(app->rator, 2)) + info->vclock += 1; + + /* Check for (call-with-values (lambda () M) N): */ + if (SAME_OBJ(app->rator, scheme_call_with_values_proc)) { + if (SAME_TYPE(SCHEME_TYPE(app->rand1), scheme_compiled_unclosed_procedure_type)) { + Scheme_Closure_Data *data = (Scheme_Closure_Data *)app->rand1; + + if (!data->num_params) { + /* Convert to apply-values form: */ + return scheme_optimize_apply_values(app->rand2, data->code, info, + ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT) + ? ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE) + ? -1 + : 1) + : 0), + context); + } + } + } + + if (SAME_OBJ(scheme_procedure_arity_includes_proc, app->rator)) { + if (SCHEME_INTP(app->rand2)) { + Scheme_Object *proc; + Scheme_Case_Lambda *cl; + int i, cnt; + + proc = lookup_constant_proc(info, app->rand1); + if (proc) { + if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) { + cnt = 1; + cl = NULL; + } else { + cl = (Scheme_Case_Lambda *)proc; + cnt = cl->count; + } + + for (i = 0; i < cnt; i++) { + if (cl) proc = cl->array[i]; + + if (SAME_TYPE(SCHEME_TYPE(proc), scheme_compiled_unclosed_procedure_type)) { + Scheme_Closure_Data *data = (Scheme_Closure_Data *)proc; + int n = SCHEME_INT_VAL(app->rand2), ok; + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) { + ok = ((data->num_params - 1) <= n); + } else { + ok = (data->num_params == n); + } + if (ok) { + info->preserves_marks = 1; + info->single_result = 1; + return scheme_true; + } + } else { + break; + } + } + + if (i == cnt) { + info->preserves_marks = 1; + info->single_result = 1; + return scheme_false; + } + } + } + } + + info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS); + info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT); + if (rator_flags & CLOS_RESULT_TENTATIVE) { + info->preserves_marks = -info->preserves_marks; + info->single_result = -info->single_result; + } + + /* Ad hoc optimization of (unsafe-fx+ 0), etc. */ + if (SCHEME_PRIMP(app->rator) + && (SCHEME_PRIM_PROC_FLAGS(app->rator) & SCHEME_PRIM_IS_UNSAFE_FUNCTIONAL)) { + int z1, z2; + + z1 = SAME_OBJ(app->rand1, scheme_make_integer(0)); + z2 = SAME_OBJ(app->rand2, scheme_make_integer(0)); + if (IS_NAMED_PRIM(app->rator, "unsafe-fx+")) { + if (z1) + return app->rand2; + else if (z2) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx-")) { + if (z2) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx*")) { + if (z1 || z2) + return scheme_make_integer(0); + if (SAME_OBJ(app->rand1, scheme_make_integer(1))) + return app->rand2; + if (SAME_OBJ(app->rand2, scheme_make_integer(1))) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-fx/") + || IS_NAMED_PRIM(app->rator, "unsafe-fxquotient")) { + if (z1) + return scheme_make_integer(0); + if (SAME_OBJ(app->rand2, scheme_make_integer(1))) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-fxremainder") + || IS_NAMED_PRIM(app->rator, "unsafe-fxmodulo")) { + if (z1) + return scheme_make_integer(0); + if (SAME_OBJ(app->rand2, scheme_make_integer(1))) + return scheme_make_integer(0); + } + + z1 = (SCHEME_FLOATP(app->rand1) && (SCHEME_FLOAT_VAL(app->rand1) == 0.0)); + z2 = (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 0.0)); + + if (IS_NAMED_PRIM(app->rator, "unsafe-fl+")) { + if (z1) + return app->rand2; + else if (z2) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl-")) { + if (z2) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl*")) { + if (SCHEME_FLOATP(app->rand1) && (SCHEME_FLOAT_VAL(app->rand1) == 1.0)) + return app->rand2; + if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-fl/") + || IS_NAMED_PRIM(app->rator, "unsafe-flquotient")) { + if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) + return app->rand1; + } else if (IS_NAMED_PRIM(app->rator, "unsafe-flremainder") + || IS_NAMED_PRIM(app->rator, "unsafe-flmodulo")) { + if (SCHEME_FLOATP(app->rand2) && (SCHEME_FLOAT_VAL(app->rand2) == 1.0)) + return scheme_make_double(0.0); + } + } + + register_flonum_argument_types(NULL, NULL, app, info); + + return check_unbox_rotation((Scheme_Object *)app, app->rator, 2, info); +} + +Scheme_Object *scheme_optimize_apply_values(Scheme_Object *f, Scheme_Object *e, + Optimize_Info *info, + int e_single_result, + int context) +/* f and e are already optimized */ +{ + Scheme_Object *f_is_proc = NULL; + + info->preserves_marks = 0; + info->single_result = 0; + + { + Scheme_Object *rev; + if (SAME_TYPE(SCHEME_TYPE(f), scheme_local_type)) { + rev = optimize_reverse(info, SCHEME_LOCAL_POS(f), 1); + } else + rev = f; + + if (rev) { + int rator2_flags; + Scheme_Object *o_f; + o_f = optimize_for_inline(info, rev, 1, NULL, NULL, NULL, &rator2_flags, context, 0); + if (o_f) { + f_is_proc = rev; + + if (SAME_TYPE(SCHEME_TYPE(o_f), scheme_compiled_unclosed_procedure_type)) { + Scheme_Closure_Data *data2 = (Scheme_Closure_Data *)o_f; + int flags = SCHEME_CLOSURE_DATA_FLAGS(data2); + info->preserves_marks = !!(flags & CLOS_PRESERVES_MARKS); + info->single_result = !!(flags & CLOS_SINGLE_RESULT); + if (flags & CLOS_RESULT_TENTATIVE) { + info->preserves_marks = -info->preserves_marks; + info->single_result = -info->single_result; + } + } + } + } + + if (!f_is_proc && SCHEME_PROCP(f)) { + f_is_proc = f; + } + } + + if (f_is_proc && (e_single_result > 0)) { + /* Just make it an application (N M): */ + Scheme_App2_Rec *app2; + Scheme_Object *cloned, *f_cloned; + + app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec); + app2->iso.so.type = scheme_application2_type; + + /* We'd like to try to inline here. The problem is that + e (the argument) has been optimized already, + which means it's in the wrong coordinate system. + If we can shift-clone it, then it will be back in the right + coordinates. */ + + cloned = scheme_optimize_clone(1, e, info, 0, 0); + if (cloned) { + if (SAME_TYPE(SCHEME_TYPE(f_is_proc), scheme_compiled_unclosed_procedure_type)) + f_cloned = scheme_optimize_clone(1, f_is_proc, info, 0, 0); + else { + /* Otherwise, no clone is needed; in the case of a lexical + variable, we already reversed it. */ + f_cloned = f_is_proc; + } + + if (f_cloned) { + app2->rator = f_cloned; + app2->rand = cloned; + info->inline_fuel >>= 1; /* because we've already optimized the rand */ + return optimize_application2((Scheme_Object *)app2, info, context); + } + } + + app2->rator = f; + app2->rand = e; + return (Scheme_Object *)app2; + } + + { + Scheme_Object *av; + av = scheme_alloc_object(); + av->type = scheme_apply_values_type; + SCHEME_PTR1_VAL(av) = f; + SCHEME_PTR2_VAL(av) = e; + return av; + } +} + +static Scheme_Object *optimize_sequence(Scheme_Object *o, Optimize_Info *info, int context) +{ + Scheme_Sequence *s = (Scheme_Sequence *)o; + Scheme_Object *le; + int i, count, prev_size; + int drop = 0, preserves_marks = 0, single_result = 0; + + count = s->count; + for (i = 0; i < count; i++) { + prev_size = info->size; + + le = scheme_optimize_expr(s->array[i], info, + ((i + 1 == count) + ? scheme_optimize_tail_context(context) + : 0)); + if (i == s->count - 1) { + single_result = info->single_result; + preserves_marks = info->preserves_marks; + } + + /* Inlining and constant propagation can expose + omittable expressions. */ + if ((i + 1 != count) + && scheme_omittable_expr(le, -1, -1, 0, NULL, -1)) { + drop++; + info->size = prev_size; + s->array[i] = NULL; + } else { + s->array[i] = le; + } + } + + info->preserves_marks = preserves_marks; + info->single_result = single_result; + + if (drop + 1 == s->count) { + return s->array[drop]; + } else if (drop) { + Scheme_Sequence *s2; + int j = 0; + + s2 = scheme_malloc_sequence(s->count - drop); + s2->so.type = s->so.type; + s2->count = s->count - drop; + + for (i = 0; i < s->count; i++) { + if (s->array[i]) { + s2->array[j++] = s->array[i]; + } + } + + s = s2; + } + + return (Scheme_Object *)s; +} + +int scheme_compiled_duplicate_ok(Scheme_Object *fb) +{ + return (SCHEME_VOIDP(fb) + || SAME_OBJ(fb, scheme_true) + || SCHEME_FALSEP(fb) + || SCHEME_SYMBOLP(fb) + || SCHEME_KEYWORDP(fb) + || SCHEME_EOFP(fb) + || SCHEME_INTP(fb) + || SCHEME_NULLP(fb) + || (SCHEME_CHARP(fb) && (SCHEME_CHAR_VAL(fb) < 256)) + || SAME_TYPE(SCHEME_TYPE(fb), scheme_local_type) + /* Values that are hashed by the printer to avoid + duplication: */ + || SCHEME_CHAR_STRINGP(fb) + || SCHEME_BYTE_STRINGP(fb) + || SAME_TYPE(SCHEME_TYPE(fb), scheme_regexp_type) + || SCHEME_NUMBERP(fb) + || SCHEME_PRIMP(fb)); +} + +static int equivalent_exprs(Scheme_Object *a, Scheme_Object *b) +{ + if (SAME_OBJ(a, b)) + return 1; + if (SAME_TYPE(SCHEME_TYPE(a), scheme_local_type) + && SAME_TYPE(SCHEME_TYPE(b), scheme_local_type) + && (SCHEME_LOCAL_POS(a) == SCHEME_LOCAL_POS(b))) + return 1; + + return 0; +} + +static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int context) +{ + Scheme_Branch_Rec *b; + Scheme_Object *t, *tb, *fb; + int preserves_marks = 1, single_result = 1; + + b = (Scheme_Branch_Rec *)o; + + t = b->test; + tb = b->tbranch; + fb = b->fbranch; + + if (context & OPT_CONTEXT_BOOLEAN) { + /* For test position, convert (if #t #f) to */ + if (SAME_OBJ(tb, scheme_true) && SAME_OBJ(fb, scheme_false)) + return scheme_optimize_expr(t, info, context); + + /* Convert (if expr) to (if #t expr) */ + if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type) + && SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type) + && (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb))) { + b->tbranch = tb = scheme_true; + } + } + + t = scheme_optimize_expr(t, info, OPT_CONTEXT_BOOLEAN); + + /* Try optimize: (if (not x) y z) => (if x z y) */ + while (1) { + if (SAME_TYPE(SCHEME_TYPE(t), scheme_application2_type)) { + Scheme_App2_Rec *app; + + app = (Scheme_App2_Rec *)t; + if (SAME_PTR(scheme_not_prim, app->rator)) { + t = tb; + tb = fb; + fb = t; + t = app->rand; + } else + break; + } else + break; + } + + info->vclock += 1; /* model branch as clock increment */ + + if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) { + info->size -= 1; + if (SCHEME_FALSEP(t)) + return scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); + else + return scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); + } else if (SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_quote_syntax_type) + || SAME_TYPE(SCHEME_TYPE(t), scheme_compiled_unclosed_procedure_type)) { + info->size -= 1; /* could be more precise for better for procedure size */ + return scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); + } + + tb = scheme_optimize_expr(tb, info, scheme_optimize_tail_context(context)); + + if (!info->preserves_marks) + preserves_marks = 0; + else if (info->preserves_marks < 0) + preserves_marks = -1; + if (!info->single_result) + single_result = 0; + else if (info->single_result < 0) + single_result = -1; + + fb = scheme_optimize_expr(fb, info, scheme_optimize_tail_context(context)); + + if (!info->preserves_marks) + preserves_marks = 0; + else if (preserves_marks && (info->preserves_marks < 0)) + preserves_marks = -1; + if (!info->single_result) + single_result = 0; + else if (single_result && (info->single_result < 0)) + single_result = -1; + + info->vclock += 1; /* model join as clock increment */ + info->preserves_marks = preserves_marks; + info->single_result = single_result; + + /* Try optimize: (if x x #f) => x */ + if (SAME_TYPE(SCHEME_TYPE(t), scheme_local_type) + && SAME_TYPE(SCHEME_TYPE(tb), scheme_local_type) + && (SCHEME_LOCAL_POS(t) == SCHEME_LOCAL_POS(tb)) + && SCHEME_FALSEP(fb)) { + info->size -= 2; + return t; + } + + /* Try optimize: (if v v) => v */ + if (scheme_omittable_expr(t, 1, 20, 0, NULL, -1) + && equivalent_exprs(tb, fb)) { + info->size -= 2; /* could be more precise */ + return tb; + } + + /* Convert: (if (if M N #f) M2 K) => (if M (if N M2 K) K) + for simple constants K. This is useful to expose simple + tests to the JIT. */ + if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) + && scheme_compiled_duplicate_ok(fb)) { + Scheme_Branch_Rec *b2 = (Scheme_Branch_Rec *)t; + if (SCHEME_FALSEP(b2->fbranch)) { + Scheme_Branch_Rec *b3; + b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); + b3->so.type = scheme_branch_type; + b3->test = b2->tbranch; + b3->tbranch = tb; + b3->fbranch = fb; + t = b2->test; + tb = (Scheme_Object *)b3; + } + } + + b->test = t; + b->tbranch = tb; + b->fbranch = fb; + + if (OPT_BRANCH_ADDS_NO_SIZE) { + /* Seems to work better to not to increase the size + specifically for `if' */ + } else { + info->size += 1; + } + + return o; +} + +static Scheme_Object *optimize_wcm(Scheme_Object *o, Optimize_Info *info, int context) +{ + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; + Scheme_Object *k, *v, *b; + + k = scheme_optimize_expr(wcm->key, info, 0); + + v = scheme_optimize_expr(wcm->val, info, 0); + + b = scheme_optimize_expr(wcm->body, info, scheme_optimize_tail_context(context)); + + if (scheme_omittable_expr(k, 1, 20, 0, info, -1) + && scheme_omittable_expr(v, 1, 20, 0, info, -1) + && scheme_omittable_expr(b, -1, 20, 0, info, -1)) + return b; + + /* info->single_result is already set */ + info->preserves_marks = 0; + + wcm->key = k; + wcm->val = v; + wcm->body = b; + + info->size += 1; + + return (Scheme_Object *)wcm; +} + +/*========================================================================*/ +/* other syntax */ +/*========================================================================*/ + +static Scheme_Object * +define_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + Scheme_Object *vars = SCHEME_VEC_ELS(data)[0]; + Scheme_Object *val = SCHEME_VEC_ELS(data)[1]; + + optimize_info_used_top(info); + val = scheme_optimize_expr(val, info, 0); + + SCHEME_VEC_ELS(data)[0] = vars; + SCHEME_VEC_ELS(data)[1] = val; + + return data; +} + +static Scheme_Object * +set_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; + Scheme_Object *var, *val; + + var = sb->var; + val = sb->val; + + val = scheme_optimize_expr(val, info, 0); + + info->preserves_marks = 1; + info->single_result = 1; + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { + int pos, delta; + + pos = SCHEME_LOCAL_POS(var); + + /* Register that we use this variable: */ + optimize_info_lookup(info, pos, NULL, NULL, 0, 0, NULL); + + /* Offset: */ + delta = optimize_info_get_shift(info, pos); + if (delta) + var = scheme_make_local(scheme_local_type, pos + delta, 0); + + info->vclock++; + } else { + optimize_info_used_top(info); + } + + sb->var = var; + sb->val = val; + + return (Scheme_Object *)sb; +} + +static Scheme_Object * +set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data, *naya; + Scheme_Object *var, *val; + + naya = MALLOC_ONE_TAGGED(Scheme_Set_Bang); + memcpy(naya, sb, sizeof(Scheme_Set_Bang)); + + var = naya->var; + val = naya->val; + + val = scheme_optimize_clone(dup_ok, val, info, delta, closure_depth); + if (!val) return NULL; + if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { + var = scheme_optimize_clone(dup_ok, var, info, delta, closure_depth); + if (!var) return NULL; + } + + naya->var = var; + naya->val = val; + + return (Scheme_Object *)naya; +} + +static Scheme_Object *set_shift(Scheme_Object *data, int delta, int after_depth) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; + Scheme_Object *e; + + e = scheme_optimize_shift(sb->var, delta, after_depth); + sb->var = e; + + e = scheme_optimize_shift(sb->val, delta, after_depth); + sb->val = e; + + return (Scheme_Object *)sb; +} + +static Scheme_Object * +ref_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + optimize_info_used_top(info); + + info->preserves_marks = 1; + info->single_result = 1; + info->size++; + + return data; +} + +static Scheme_Object * +ref_shift(Scheme_Object *data, int delta, int after_depth) +{ + Scheme_Object *v; + + v = scheme_optimize_shift(SCHEME_PTR1_VAL(data), delta, after_depth); + SCHEME_PTR1_VAL(data) = v; + + v = scheme_optimize_shift(SCHEME_PTR2_VAL(data), delta, after_depth); + SCHEME_PTR2_VAL(data) = v; + + return data; +} + +static Scheme_Object * +apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + Scheme_Object *f, *e; + + f = SCHEME_PTR1_VAL(data); + e = SCHEME_PTR2_VAL(data); + + f = scheme_optimize_expr(f, info, 0); + e = scheme_optimize_expr(e, info, 0); + + info->size += 1; + info->vclock += 1; + + return scheme_optimize_apply_values(f, e, info, info->single_result, context); +} + +static Scheme_Object * +apply_values_shift(Scheme_Object *data, int delta, int after_depth) +{ + Scheme_Object *e; + + e = scheme_optimize_shift(SCHEME_PTR1_VAL(data), delta, after_depth); + SCHEME_PTR1_VAL(data) = e; + + e = scheme_optimize_shift(SCHEME_PTR2_VAL(data), delta, after_depth); + SCHEME_PTR2_VAL(data) = e; + + return data; +} + +static Scheme_Object * +apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) +{ + Scheme_Object *f, *e; + + f = SCHEME_PTR1_VAL(data); + e = SCHEME_PTR2_VAL(data); + + f = scheme_optimize_clone(dup_ok, f, info, delta, closure_depth); + if (!f) return NULL; + e = scheme_optimize_clone(dup_ok, e, info, delta, closure_depth); + if (!e) return NULL; + + data = scheme_alloc_object(); + data->type = scheme_apply_values_type; + SCHEME_PTR1_VAL(data) = f; + SCHEME_PTR2_VAL(data) = e; + + return data; +} + +static Scheme_Object * +case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context) +{ + Scheme_Object *le; + int i; + Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; + mzshort **tus, *tu; + int *tu_lens, tup, tu_count = 0; + + if (info->transitive_use_pos) { + /* We'll need to merge transitive_use arrays */ + tup = info->transitive_use_pos - 1; + tus = (mzshort **)MALLOC_N(mzshort*, seq->count); + tu_lens = (int*)MALLOC_N_ATOMIC(int, seq->count); + } else { + tup = 0; + tus = NULL; + tu_lens = NULL; + } + + for (i = 0; i < seq->count; i++) { + le = seq->array[i]; + le = scheme_optimize_expr(le, info, 0); + seq->array[i] = le; + + if (tus) { + tus[i] = info->transitive_use[tup]; + tu_lens[i] = info->transitive_use_len[tup]; + if (tus[i]) { + tu_count += tu_lens[i]; + } + info->transitive_use[tup] = NULL; + info->transitive_use_len[tup] = 0; + } + } + + info->preserves_marks = 1; + info->single_result = 1; + info->size += 1; + + if (tu_count) { + tu = MALLOC_N_ATOMIC(mzshort, tu_count); + tu_count = 0; + for (i = 0; i < seq->count; i++) { + if (tus[i]) { + memcpy(tu + tu_count, tus[i], tu_lens[i] * sizeof(mzshort)); + tu_count += tu_lens[i]; + } + } + info->transitive_use[tup] = tu; + info->transitive_use_len[tup] = tu_count; + } + + return expr; +} + +static Scheme_Object * +case_lambda_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) +{ + Scheme_Object *le; + int i, sz; + Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data; + Scheme_Case_Lambda *seq2; + + sz = sizeof(Scheme_Case_Lambda) + ((seq->count - 1) * sizeof(Scheme_Object*)); + seq2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sz); + memcpy(seq2, seq, sz); + + for (i = 0; i < seq->count; i++) { + le = seq->array[i]; + le = scheme_optimize_clone(dup_ok, le, info, delta, closure_depth); + if (!le) return NULL; + seq2->array[i] = le; + } + + return (Scheme_Object *)seq2; +} + +static Scheme_Object * +case_lambda_shift(Scheme_Object *data, int delta, int after_depth) +{ + Scheme_Object *le; + int i; + Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data; + + for (i = 0; i < seq->count; i++) { + le = seq->array[i]; + le = scheme_optimize_shift(le, delta, after_depth); + seq->array[i] = le; + } + + return data; +} + +static Scheme_Object * +begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) +{ + int i, count; + + count = ((Scheme_Sequence *)obj)->count; + + for (i = 0; i < count; i++) { + Scheme_Object *le; + le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info, + (!i + ? scheme_optimize_result_context(context) + : 0)); + ((Scheme_Sequence *)obj)->array[i] = le; + } + + /* Optimization of expression 0 has already set single_result */ + info->preserves_marks = 1; + + info->size += 1; + + return obj; +} + +static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int for_stx) +{ + Scheme_Object *val; + Optimize_Info *einfo; + + val = SCHEME_VEC_ELS(data)[3]; + + einfo = scheme_optimize_info_create(); + if (info->inline_fuel < 0) + einfo->inline_fuel = -1; + + val = scheme_optimize_expr(val, einfo, 0); + + SCHEME_VEC_ELS(data)[3] = val; + + return data; +} + +static Scheme_Object *define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + return do_define_syntaxes_optimize(data, info, 0); +} + +static Scheme_Object *define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + return do_define_syntaxes_optimize(data, info, 1); +} + +/*========================================================================*/ +/* let, let-values, letrec, etc. */ +/*========================================================================*/ + +static int is_liftable_prim(Scheme_Object *v) +{ + if (SCHEME_PRIMP(v)) { + if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK) + >= SCHEME_PRIM_OPT_IMMEDIATE) + return 1; + } + + return 0; +} + +int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator) +{ + Scheme_Type t = SCHEME_TYPE(o); + + switch (t) { + case scheme_compiled_unclosed_procedure_type: + return !as_rator; + case scheme_case_lambda_sequence_type: + return !as_rator; + case scheme_compiled_toplevel_type: + return 1; + case scheme_local_type: + if (SCHEME_LOCAL_POS(o) > bind_count) + return 1; + break; + case scheme_branch_type: + if (fuel) { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o; + if (scheme_is_liftable(b->test, bind_count, fuel - 1, 0) + && scheme_is_liftable(b->tbranch, bind_count, fuel - 1, as_rator) + && scheme_is_liftable(b->fbranch, bind_count, fuel - 1, as_rator)) + return 1; + } + break; + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)o; + int i; + if (!is_liftable_prim(app->args[0])) + return 0; + if (0) /* not resolved, yet */ + if (bind_count >= 0) + bind_count += app->num_args; + for (i = app->num_args + 1; i--; ) { + if (!scheme_is_liftable(app->args[i], bind_count, fuel - 1, 1)) + return 0; + } + return 1; + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; + if (!is_liftable_prim(app->rator)) + return 0; + if (0) /* not resolved, yet */ + if (bind_count >= 0) + bind_count += 1; + if (scheme_is_liftable(app->rator, bind_count, fuel - 1, 1) + && scheme_is_liftable(app->rand, bind_count, fuel - 1, 1)) + return 1; + } + break; + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; + if (!is_liftable_prim(app->rator)) + return 0; + if (0) /* not resolved, yet */ + if (bind_count >= 0) + bind_count += 2; + if (scheme_is_liftable(app->rator, bind_count, fuel - 1, 1) + && scheme_is_liftable(app->rand1, bind_count, fuel - 1, 1) + && scheme_is_liftable(app->rand2, bind_count, fuel - 1, 1)) + return 1; + } + break; + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *lh = (Scheme_Let_Header *)o; + int i; + int post_bind = !(SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); + + if (post_bind) { + o = lh->body; + for (i = lh->num_clauses; i--; ) { + if (!scheme_is_liftable(((Scheme_Compiled_Let_Value *)o)->value, bind_count, fuel - 1, as_rator)) + return 0; + o = ((Scheme_Compiled_Let_Value *)o)->body; + } + if (scheme_is_liftable(o, bind_count + lh->count, fuel - 1, as_rator)) + return 1; + } + break; + } + default: + if (t > _scheme_compiled_values_types_) + return 1; + } + + return 0; +} + +int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info) +{ + if (scheme_compiled_duplicate_ok(value)) + return 1; + + if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) { + int sz; + sz = closure_body_size((Scheme_Closure_Data *)value, 1, info, NULL); + if ((sz >= 0) && (sz <= MAX_PROC_INLINE_SIZE)) + return 1; + } + + if (SAME_TYPE(scheme_case_lambda_sequence_type, SCHEME_TYPE(value))) { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)value; + int i; + for (i = cl->count; i--; ) { + if (!scheme_compiled_propagate_ok(cl->array[i], info)) + return 0; + } + return 1; + } + + + if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_toplevel_type)) { + if (info->top_level_consts) { + int pos; + pos = SCHEME_TOPLEVEL_POS(value); + value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + value = scheme_no_potential_size(value); + if (value) + return 1; + } + } + + return 0; +} + +int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info) +{ + while (1) { + if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) + return 1; + else if (SAME_TYPE(SCHEME_TYPE(value), scheme_case_lambda_sequence_type)) { + return 1; + } else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_let_void_type)) { + /* Look for (let ([x ]) ), which is generated for optional arguments. */ + Scheme_Let_Header *lh = (Scheme_Let_Header *)value; + if (lh->num_clauses == 1) { + Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; + if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL, -1)) { + value = lv->body; + info = NULL; + } else + break; + } else + break; + } else + break; + } + + return 0; +} + +Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e) +{ + Scheme_Object *ni; + + ni = scheme_alloc_small_object(); + ni->type = scheme_noninline_proc_type; + SCHEME_PTR_VAL(ni) = e; + + return ni; +} + +static int is_values_apply(Scheme_Object *e) +{ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + return SAME_OBJ(scheme_values_func, app->args[0]); + } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; + return SAME_OBJ(scheme_values_func, app->rator); + } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; + return SAME_OBJ(scheme_values_func, app->rator); + } + + return 0; +} + +static void unpack_values_application(Scheme_Object *e, Scheme_Compiled_Let_Value *naya, + int rev_bind_order) +{ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { + Scheme_App_Rec *app = (Scheme_App_Rec *)e; + int i; + for (i = 0; i < app->num_args; i++) { + if (rev_bind_order) + naya->value = app->args[app->num_args - i]; + else + naya->value = app->args[i + 1]; + naya = (Scheme_Compiled_Let_Value *)naya->body; + } + } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; + naya->value = app->rand; + } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; + naya->value = (rev_bind_order ? app->rand2 : app->rand1); + naya = (Scheme_Compiled_Let_Value *)naya->body; + naya->value = (rev_bind_order ? app->rand1 : app->rand2); + } +} + +static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start, + Scheme_Compiled_Let_Value *pre_body, + Optimize_Info *body_info) +{ + Scheme_Compiled_Let_Value *clv; + Scheme_Object *value, *clone, *pr; + Scheme_Object *last = NULL, *first = NULL; + + clv = retry_start; + while (1) { + value = clv->value; + if (IS_COMPILED_PROC(value)) { + clone = scheme_optimize_clone(1, value, body_info, 0, 0); + if (clone) { + pr = scheme_make_raw_pair(scheme_make_raw_pair(value, clone), NULL); + } else + pr = scheme_make_raw_pair(NULL, NULL); + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + } + if (clv == pre_body) + break; + clv = (Scheme_Compiled_Let_Value *)clv->body; + } + + return first; +} + +static int set_code_flags(Scheme_Compiled_Let_Value *retry_start, + Scheme_Compiled_Let_Value *pre_body, + Scheme_Object *clones, + int set_flags, int mask_flags, int just_tentative, + int merge_flonum) +{ + Scheme_Case_Lambda *cl, *cl2, *cl3; + Scheme_Compiled_Let_Value *clv; + Scheme_Object *value, *first; + int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS; + Scheme_Closure_Data *data, *data2, *data3; + int i, count; + + /* The first in a clone pair is the one that is consulted for + references. The second one is the clone, and it's the one whose + flags are updated by optimization. So consult the clone, and set + flags in both. */ + + clv = retry_start; + while (clones) { + value = clv->value; + if (IS_COMPILED_PROC(value)) { + first = SCHEME_CAR(clones); + + if (first) { + if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) { + count = 1; + cl = NULL; + cl2 = NULL; + cl3 = NULL; + } else { + cl = (Scheme_Case_Lambda *)value; + cl2 = (Scheme_Case_Lambda *)SCHEME_CAR(first); + cl3 = (Scheme_Case_Lambda *)SCHEME_CDR(first); + count = cl->count; + } + + for (i = 0; i < count; i++) { + if (cl) { + data = (Scheme_Closure_Data *)cl->array[i]; + data2 = (Scheme_Closure_Data *)cl2->array[i]; + data3 = (Scheme_Closure_Data *)cl3->array[i]; + } else { + data = (Scheme_Closure_Data *)value; + data2 = (Scheme_Closure_Data *)SCHEME_CAR(first); + data3 = (Scheme_Closure_Data *)SCHEME_CDR(first); + } + + if (merge_flonum) { + merge_closure_flonum_map(data, data2); + merge_closure_flonum_map(data, data3); + merge_closure_flonum_map(data, data2); + } + + if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { + flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data)); + SCHEME_CLOSURE_DATA_FLAGS(data2) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data2) & mask_flags); + SCHEME_CLOSURE_DATA_FLAGS(data3) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data3) & mask_flags); + } + } + } + + clones = SCHEME_CDR(clones); + } + + if (clv == pre_body) + break; + clv = (Scheme_Compiled_Let_Value *)clv->body; + } + + return flags; +} + +int scheme_compiled_proc_body_size(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type)) + return closure_body_size((Scheme_Closure_Data *)o, 0, NULL, NULL); + else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_lambda_sequence_type)) { + Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o; + int i, sz = 0; + for (i = cl->count; i--; ) { + sz += closure_body_size((Scheme_Closure_Data *)cl->array[i], 0, NULL, NULL); + } + return sz; + } else + return 0; +} + +static int expr_size(Scheme_Object *o, Optimize_Info *info) +{ + return scheme_compiled_proc_body_size(o) + 1; +} + +int scheme_might_invoke_call_cc(Scheme_Object *value) +{ + return !scheme_is_liftable(value, -1, 10, 0); +} + +static int worth_lifting(Scheme_Object *v) +{ + Scheme_Type lhs; + lhs = SCHEME_TYPE(v); + if ((lhs == scheme_compiled_unclosed_procedure_type) + || (lhs == scheme_case_lambda_sequence_type) + || (lhs == scheme_local_type) + || (lhs == scheme_compiled_toplevel_type) + || (lhs == scheme_compiled_quote_syntax_type) + || (lhs > _scheme_compiled_values_types_)) + return 1; + return 0; +} + +Scheme_Object * +scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context) +{ + Optimize_Info *sub_info, *body_info, *rhs_info; + Scheme_Let_Header *head = (Scheme_Let_Header *)form; + Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body; + Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start; + Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL, *once_used; + int i, j, pos, is_rec, not_simply_let_star = 0, undiscourage, split_shift, skip_opts = 0; + int size_before_opt, did_set_value, checked_once; + int remove_last_one = 0, inline_fuel, rev_bind_order; + int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); + +# define pos_EARLIER(a, b) (rev_bind_order ? ((a) > (b)) : ((a) < (b))) + + if (context & OPT_CONTEXT_BOOLEAN) { + /* Special case: (let ([x M]) (if x x N)), where x is not in N, + to (if M #t N), since we're in a test position. */ + if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) { + clv = (Scheme_Compiled_Let_Value *)head->body; + if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type) + && (((clv->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT) + == 2)) { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)clv->body; + if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_local_type) + && SAME_TYPE(SCHEME_TYPE(b->tbranch), scheme_local_type) + && !SCHEME_LOCAL_POS(b->test) + && !SCHEME_LOCAL_POS(b->tbranch)) { + Scheme_Branch_Rec *b3; + + b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); + b3->so.type = scheme_branch_type; + b3->test = clv->value; + b3->tbranch = scheme_true; + if (post_bind) { + /* still need a `let' around N: */ + b3->fbranch = (Scheme_Object *)head; + clv->value = scheme_false; + clv->flags[0] = 0; /* variable now unused */ + clv->body = b->fbranch; + } else { + b3->fbranch = b->fbranch; + } + + if (post_bind) + sub_info = info; + else + sub_info = optimize_info_add_frame(info, 1, 0, 0); + + form = scheme_optimize_expr((Scheme_Object *)b3, sub_info, context); + + if (!post_bind) { + info->single_result = sub_info->single_result; + info->preserves_marks = sub_info->preserves_marks; + optimize_info_done(sub_info); + } + + return form; + } + } + } + } + + /* Special case: (let ([x E]) x) where E is lambda, case-lambda, or + a constant. (If we allowed arbitrary E here, it would affect the + tailness of E.) */ + if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) { + clv = (Scheme_Compiled_Let_Value *)head->body; + if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type) + && (((Scheme_Local *)clv->body)->position == 0)) { + if (worth_lifting(clv->value)) { + if (post_bind) { + /* Just drop the let */ + return scheme_optimize_expr(clv->value, info, context); + } else { + info = optimize_info_add_frame(info, 1, 0, 0); + body = scheme_optimize_expr(clv->value, info, context); + info->next->single_result = info->single_result; + info->next->preserves_marks = info->preserves_marks; + optimize_info_done(info); + return body; + } + } + } + } + + is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE); + + if (!is_rec) { + int try_again; + do { + try_again = 0; + /* (let ([x (let~ ([y M]) N)]) P) => (let~ ([y M]) (let ([x N]) P)) + or (let ([x (begin M ... N)]) P) => (begin M ... (let ([x N]) P)) */ + if (post_bind) { + if (head->num_clauses == 1) { + clv = (Scheme_Compiled_Let_Value *)head->body; /* ([x ...]) */ + if (SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_let_void_type)) { + Scheme_Let_Header *lh = (Scheme_Let_Header *)clv->value; /* (let~ ([y ...]) ...) */ + + value = clv->body; /* = P */ + if (lh->count) + value = scheme_optimize_shift(value, lh->count, head->count); + if (value) { + clv->body = value; + + if (!lh->num_clauses) { + clv->value = lh->body; + lh->body = (Scheme_Object *)head; + } else { + body = lh->body; + for (i = lh->num_clauses - 1; i--; ) { + body = ((Scheme_Compiled_Let_Value *)body)->body; + } + clv->value = ((Scheme_Compiled_Let_Value *)body)->body; /* N */ + ((Scheme_Compiled_Let_Value *)body)->body = (Scheme_Object *)head; + } + + head = lh; + form = (Scheme_Object *)head; + is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE); + post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); + try_again = 1; + } + } else if (SAME_TYPE(SCHEME_TYPE(clv->value), scheme_sequence_type)) { + Scheme_Sequence *seq = (Scheme_Sequence *)clv->value; /* (begin M ... N) */ + + clv->value = seq->array[seq->count - 1]; + seq->array[seq->count - 1] = (Scheme_Object *)head; + + return scheme_optimize_expr((Scheme_Object *)seq, info, context); + } + } + } + } while (try_again); + } + + split_shift = 0; + if (is_rec) { + /* Check whether we should break a prefix out into its own + letrec set. */ + body = head->body; + j = 0; + for (i = 0; i < head->num_clauses - 1; i++) { + pre_body = (Scheme_Compiled_Let_Value *)body; + if (SCHEME_CLV_FLAGS(pre_body) & SCHEME_CLV_NO_GROUP_LATER_USES) { + /* yes --- break group here */ + Scheme_Let_Header *h2; + + j += pre_body->count; + i++; + + h2 = MALLOC_ONE_TAGGED(Scheme_Let_Header); + h2->iso.so.type = scheme_compiled_let_void_type; + h2->count = head->count - j; + h2->num_clauses = head->num_clauses - i; + h2->body = pre_body->body; + SCHEME_LET_FLAGS(h2) = SCHEME_LET_RECURSIVE; + + head->count = j; + head->num_clauses = i; + + pre_body->body = (Scheme_Object *)h2; + + split_shift = h2->count; + + body = head->body; + for (j = 0; j < i; j++) { + pre_body = (Scheme_Compiled_Let_Value *)body; + pre_body->position -= split_shift; + body = pre_body->body; + } + + break; + } else { + j += pre_body->count; + body = pre_body->body; + } + } + } + + body_info = optimize_info_add_frame(info, head->count, head->count, + post_bind ? SCHEME_POST_BIND_FRAME : 0); + if (post_bind) + rhs_info = optimize_info_add_frame(info, 0, 0, 0); + else if (split_shift) + rhs_info = optimize_info_add_frame(body_info, split_shift, 0, 0); + else + rhs_info = body_info; + + body = head->body; + for (i = head->num_clauses; i--; ) { + pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; + for (j = pre_body->count; j--; ) { + if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) { + optimize_mutated(body_info, pos + j); + } else if (is_rec) { + /* Indicate that it's not yet ready, so it cannot be inlined: */ + Scheme_Object *rp; + rp = scheme_make_raw_pair(scheme_false, NULL); + if (rp_last) + SCHEME_CDR(rp_last) = rp; + else + ready_pairs = rp; + rp_last = rp; + optimize_propagate(body_info, pos+j, rp_last, 0); + } + } + body = pre_body->body; + } + + if (OPT_ESTIMATE_FUTURE_SIZES) { + if (is_rec && !body_info->letrec_not_twice) { + /* For each identifier bound to a procedure, register an initial + size estimate, which is used to discourage early loop unrolling + at the expense of later inlining. */ + body = head->body; + pre_body = NULL; + for (i = head->num_clauses; i--; ) { + pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; + + if ((pre_body->count == 1) + && IS_COMPILED_PROC(pre_body->value) + && !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) { + optimize_propagate(body_info, pos, scheme_estimate_closure_size(pre_body->value), 0); + } + + body = pre_body->body; + } + rhs_info->use_psize = 1; + } + } + + rev_bind_order = 0; + if (is_rec) + rev_bind_order = 1; + else if (head->num_clauses > 1) { + int pos; + body = head->body; + pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; + body = pre_body->body; + for (i = head->num_clauses - 1; i--; ) { + pre_body = (Scheme_Compiled_Let_Value *)body; + if (pre_body->position < pos) { + rev_bind_order = 1; + break; + } else if (pre_body->position > pos) { + break; + } + body = pre_body->body; + } + } + + prev_body = NULL; + body = head->body; + pre_body = NULL; + retry_start = NULL; + ready_pairs_start = NULL; + did_set_value = 0; + for (i = head->num_clauses; i--; ) { + pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; + + size_before_opt = body_info->size; + + if ((pre_body->count == 1) + && IS_COMPILED_PROC(pre_body->value) + && !optimize_is_used(body_info, pos)) { + if (!body_info->transitive_use) { + mzshort **tu; + int *tu_len; + tu = (mzshort **)scheme_malloc(sizeof(mzshort *) * head->count); + tu_len = (int *)scheme_malloc_atomic(sizeof(int) * head->count); + memset(tu_len, 0, sizeof(int) * head->count); + body_info->transitive_use = tu; + body_info->transitive_use_len = tu_len; + } + body_info->transitive_use_pos = pos + 1; + } + + if (is_rec && OPT_DISCOURAGE_EARLY_INLINE && !rhs_info->letrec_not_twice + && IS_COMPILED_PROC(pre_body->value)) { + inline_fuel = rhs_info->inline_fuel; + if (inline_fuel > 2) + rhs_info->inline_fuel = 2; + rhs_info->letrec_not_twice++; + undiscourage = 1; + } else { + inline_fuel = 0; + undiscourage = 0; + } + + if (!skip_opts) { + value = scheme_optimize_expr(pre_body->value, rhs_info, 0); + pre_body->value = value; + } else { + value = pre_body->value; + --skip_opts; + } + + if (undiscourage) { + rhs_info->inline_fuel = inline_fuel; + --rhs_info->letrec_not_twice; + } + + body_info->transitive_use_pos = 0; + + if (is_rec && !not_simply_let_star) { + /* Keep track of whether we can simplify to let*: */ + if (scheme_might_invoke_call_cc(value) + || optimize_any_uses(body_info, 0, pos+pre_body->count)) + not_simply_let_star = 1; + } + + /* Change (let-values ([(id ...) (values e ...)]) body) + to (let-values ([id e] ...) body) for simple e. */ + if ((pre_body->count != 1) + && is_values_apply(value) + && scheme_omittable_expr(value, pre_body->count, -1, 0, info, + (is_rec + ? (pre_body->position + pre_body->count) + : -1))) { + if (!pre_body->count && !i) { + /* We want to drop the clause entirely, but doing it + here messes up the loop for letrec. So wait and + remove it at the end. */ + remove_last_one = 1; + } else { + Scheme_Compiled_Let_Value *naya; + Scheme_Object *rest = pre_body->body; + int *new_flags; + int cnt; + + /* This conversion may reorder the expressions. */ + if (pre_body->count) { + if (rev_bind_order) + cnt = 0; + else + cnt = pre_body->count - 1; + + while (1) { + naya = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); + naya->iso.so.type = scheme_compiled_let_value_type; + naya->body = rest; + naya->count = 1; + naya->position = pre_body->position + cnt; + new_flags = (int *)scheme_malloc_atomic(sizeof(int)); + new_flags[0] = pre_body->flags[cnt]; + naya->flags = new_flags; + rest = (Scheme_Object *)naya; + + if (rev_bind_order) { + cnt++; + if (cnt >= pre_body->count) + break; + } else { + if (!cnt) + break; + cnt--; + } + } + } + + naya = (Scheme_Compiled_Let_Value *)rest; + unpack_values_application(value, naya, rev_bind_order); + if (prev_body) + prev_body->body = (Scheme_Object *)naya; + else + head->body = (Scheme_Object *)naya; + head->num_clauses += (pre_body->count - 1); + i += (pre_body->count - 1); + if (pre_body->count) { + /* We're backing up. Since the RHSs have been optimized + already, don re-optimize. */ + skip_opts = pre_body->count - 1; + pre_body = naya; + body = (Scheme_Object *)naya; + value = pre_body->value; + pos = pre_body->position; + } else { + /* We've dropped this clause entirely. */ + i++; + if (i > 0) { + body = (Scheme_Object *)naya; + continue; + } else + break; + } + } + } + + checked_once = 0; + + if ((pre_body->count == 1) + && !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) { + int indirect = 0, indirect_binding = 0; + + while (indirect < 10) { + if (SAME_TYPE(SCHEME_TYPE(value), scheme_sequence_type)) { + Scheme_Sequence *seq = (Scheme_Sequence *)value; + value = seq->array[seq->count - 1]; + indirect++; + } else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_let_void_type)) { + Scheme_Let_Header *head2 = (Scheme_Let_Header *)value; + int i; + + if (head2->num_clauses < 10) { + value = head2->body; + for (i = head2->num_clauses; i--; ) { + value = ((Scheme_Compiled_Let_Value *)value)->body; + } + } + indirect++; + if (head2->count) + indirect_binding = 1; + } else + break; + } + + if (indirect_binding) { + /* only allow constants */ + if (SCHEME_TYPE(value) < _scheme_compiled_values_types_) + value = NULL; + } + + if (value && SAME_TYPE(SCHEME_TYPE(value), scheme_local_type)) { + /* Don't optimize reference to a local binding + that's not available yet, or that's mutable. */ + int vpos; + vpos = SCHEME_LOCAL_POS(value); + if (!post_bind && (vpos < head->count) && !pos_EARLIER(vpos, pos)) + value = NULL; + else { + /* Convert value back to a pre-optimized local coordinates. + Unless post_bind, this must be done with respect to + body_info, not rhs_info, because we attach the value to + body_info: */ + value = optimize_reverse(post_bind ? rhs_info : body_info, vpos, 1); + + /* Double-check that the value is ready, because we might be + nested in the RHS of a `letrec': */ + if (value) + if (!optimize_info_is_ready(body_info, SCHEME_LOCAL_POS(value))) + value = NULL; + } + } + + if (value && (scheme_compiled_propagate_ok(value, body_info))) { + int cnt; + + if (is_rec) + cnt = 2; + else + cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); + + optimize_propagate(body_info, pos, value, cnt == 1); + did_set_value = 1; + checked_once = 1; + } else if (value && !is_rec) { + int cnt; + + if (scheme_expr_produces_flonum(value)) + optimize_produces_flonum(body_info, pos); + + if (!indirect) { + checked_once = 1; + cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); + if (cnt == 1) { + /* used only once; we may be able to shift the expression to the use + site, instead of binding to a temporary */ + once_used = make_once_used(value, pos, rhs_info->vclock, NULL); + if (!last_once_used) + first_once_used = once_used; + else + last_once_used->next = once_used; + last_once_used = once_used; + optimize_propagate(body_info, pos, (Scheme_Object *)once_used, 1); + } + } + } + } + + if (!checked_once) { + /* Didn't handle once-used check in case of copy propagation, so check here. */ + int i, cnt; + for (i = pre_body->count; i--; ) { + if (!(pre_body->flags[i] & SCHEME_WAS_SET_BANGED)) { + cnt = ((pre_body->flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); + if (cnt == 1) { + /* Need to register as once-used, in case of copy propagation */ + once_used = make_once_used(NULL, pos+i, rhs_info->vclock, NULL); + if (!last_once_used) + first_once_used = once_used; + else + last_once_used->next = once_used; + last_once_used = once_used; + optimize_propagate(body_info, pos+i, (Scheme_Object *)once_used, 1); + } + } + } + } + + if (!retry_start) { + retry_start = pre_body; + ready_pairs_start = ready_pairs; + } + + /* Re-optimize to inline letrec bindings? */ + if (is_rec + && !body_info->letrec_not_twice + && ((i < 1) + || (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1) + && !scheme_is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1)))) { + if (did_set_value) { + /* Next RHS ends a reorderable sequence. + Re-optimize from retry_start to pre_body, inclusive. + For procedures, assume CLOS_SINGLE_RESULT and CLOS_PRESERVES_MARKS for all, + but then assume not for all if any turn out not (i.e., approximate fix point). */ + int flags; + Scheme_Object *clones, *cl, *cl_first; + /* Reset "ready" flags: */ + for (rp_last = ready_pairs_start; !SAME_OBJ(rp_last, ready_pairs); rp_last = SCHEME_CDR(rp_last)) { + SCHEME_CAR(rp_last) = scheme_false; + } + /* Set-flags loop: */ + clones = make_clones(retry_start, pre_body, rhs_info); + (void)set_code_flags(retry_start, pre_body, clones, + CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, + 0xFFFF, + 0, + 0); + /* Re-optimize loop: */ + clv = retry_start; + cl = clones; + while (1) { + value = clv->value; + if (cl) { + cl_first = SCHEME_CAR(cl); + if (!cl_first) + cl = SCHEME_CDR(cl); + } else + cl_first = NULL; + if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) { + /* Try optimization. */ + Scheme_Object *self_value; + int sz; + char use_psize; + + if ((clv->count == 1) + && rhs_info->transitive_use + && !optimize_is_used(body_info, clv->position)) { + body_info->transitive_use[clv->position] = NULL; + body_info->transitive_use_pos = clv->position + 1; + } + + cl = SCHEME_CDR(cl); + self_value = SCHEME_CDR(cl_first); + + /* Drop old size, and remove old inline fuel: */ + sz = scheme_compiled_proc_body_size(value); + rhs_info->size -= (sz + 1); + + /* Setting letrec_not_twice prevents inlinining + of letrec bindings in this RHS. There's a small + chance that we miss some optimizations, but we + avoid the possibility of N^2 behavior. */ + if (!OPT_DISCOURAGE_EARLY_INLINE) + rhs_info->letrec_not_twice++; + use_psize = rhs_info->use_psize; + rhs_info->use_psize = info->use_psize; + + value = scheme_optimize_expr(self_value, rhs_info, 0); + + if (!OPT_DISCOURAGE_EARLY_INLINE) + --rhs_info->letrec_not_twice; + rhs_info->use_psize = use_psize; + + clv->value = value; + + if (!(clv->flags[0] & SCHEME_WAS_SET_BANGED)) { + if (scheme_compiled_propagate_ok(value, rhs_info)) { + /* Register re-optimized as the value for the binding, but + maybe only if it didn't grow too much: */ + int new_sz; + if (OPT_LIMIT_FUNCTION_RESIZE) + new_sz = scheme_compiled_proc_body_size(value); + else + new_sz = 0; + if (new_sz < 4 * sz) + optimize_propagate(body_info, clv->position, value, 0); + } + } + + body_info->transitive_use_pos = 0; + } + if (clv == pre_body) + break; + { + /* Since letrec is really letrec*, the variables + for this binding are now ready: */ + int i; + for (i = clv->count; i--; ) { + if (!(clv->flags[i] & SCHEME_WAS_SET_BANGED)) { + SCHEME_CAR(ready_pairs_start) = scheme_true; + ready_pairs_start = SCHEME_CDR(ready_pairs_start); + } + } + } + clv = (Scheme_Compiled_Let_Value *)clv->body; + } + /* Check flags loop: */ + flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0, 0); + /* Reset-flags loop: */ + (void)set_code_flags(retry_start, pre_body, clones, + (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), + ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE), + 1, + 1); + } + retry_start = NULL; + ready_pairs_start = NULL; + did_set_value = 0; + } + + if (is_rec) { + /* Since letrec is really letrec*, the variables + for this binding are now ready: */ + int i; + for (i = pre_body->count; i--; ) { + if (!(pre_body->flags[i] & SCHEME_WAS_SET_BANGED)) { + SCHEME_CAR(ready_pairs) = scheme_true; + ready_pairs = SCHEME_CDR(ready_pairs); + } + } + } + + if (remove_last_one) { + head->num_clauses -= 1; + body = (Scheme_Object *)pre_body->body; + if (prev_body) { + prev_body->body = body; + pre_body = prev_body; + } else { + head->body = body; + pre_body = NULL; + } + break; + } + + prev_body = pre_body; + body = pre_body->body; + } + + if (post_bind) { + body_info->size = rhs_info->size; + body_info->vclock = rhs_info->vclock; + } + + if (split_shift) { + optimize_info_done(rhs_info); + } + + body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context)); + if (head->num_clauses) + pre_body->body = body; + else + head->body = body; + + info->single_result = body_info->single_result; + info->preserves_marks = body_info->preserves_marks; + info->vclock = body_info->vclock; + + /* Clear used flags where possible */ + body = head->body; + for (i = head->num_clauses; i--; ) { + int used = 0, j; + + pre_body = (Scheme_Compiled_Let_Value *)body; + pos = pre_body->position; + + for (j = pre_body->count; j--; ) { + if (optimize_is_used(body_info, pos+j)) { + used = 1; + break; + } + } + + if (!used + && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, -1) + || ((pre_body->count == 1) + && first_once_used + && (first_once_used->pos == pos) + && first_once_used->used))) { + for (j = pre_body->count; j--; ) { + if (pre_body->flags[j] & SCHEME_WAS_USED) { + pre_body->flags[j] -= SCHEME_WAS_USED; + } + + if (first_once_used && (first_once_used->pos == (pos + j))) + first_once_used = first_once_used->next; + } + if (pre_body->count == 1) { + /* Drop expr and deduct from size to aid further inlining. */ + int sz; + sz = expr_size(pre_body->value, info); + pre_body->value = scheme_false; + info->size -= sz; + } + } else { + for (j = pre_body->count; j--; ) { + pre_body->flags[j] |= SCHEME_WAS_USED; + if (optimize_is_flonum_arg(body_info, pos+j, 0)) + pre_body->flags[j] |= SCHEME_WAS_FLONUM_ARGUMENT; + + if (first_once_used && (first_once_used->pos == (pos+j))) { + if (first_once_used->vclock < 0) { + /* single-use no longer true, due to copy propagation */ + pre_body->flags[j] |= SCHEME_USE_COUNT_MASK; + } + first_once_used = first_once_used->next; + } + } + info->size += 1; + } + body = pre_body->body; + } + + /* Optimized away all clauses? */ + if (!head->num_clauses) { + optimize_info_done(body_info); + return head->body; + } + + if (is_rec && !not_simply_let_star) { + /* We can simplify letrec to let* */ + SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE; + SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR; + } + + { + int extract_depth = 0; + + value = NULL; + + /* Check again for (let ([x ]) x). */ + if (!is_rec && (head->count == 1) && (head->num_clauses == 1)) { + clv = (Scheme_Compiled_Let_Value *)head->body; + if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type) + && (((Scheme_Local *)clv->body)->position == 0)) { + if (worth_lifting(clv->value)) { + value = clv->value; + extract_depth = 1; + } + } + } + + /* Check for (let ([unused #f] ...) ) */ + if (!value) { + if (head->count == head->num_clauses) { + body = head->body; + for (i = head->num_clauses; i--; ) { + pre_body = (Scheme_Compiled_Let_Value *)body; + if ((pre_body->count != 1) + || !SCHEME_FALSEP(pre_body->value) + || (pre_body->flags[0] & SCHEME_WAS_USED)) + break; + body = pre_body->body; + } + if (i < 0) { + if (worth_lifting(body)) { + value = body; + extract_depth = head->count; + rhs_info = body_info; + post_bind = 0; + } + } + } + } + + if (value) { + value = scheme_optimize_clone(1, value, rhs_info, 0, 0); + + if (value) { + sub_info = optimize_info_add_frame(info, post_bind ? 0 : extract_depth, 0, 0); + sub_info->inline_fuel = 0; + value = scheme_optimize_expr(value, sub_info, context); + info->single_result = sub_info->single_result; + info->preserves_marks = sub_info->preserves_marks; + optimize_info_done(sub_info); + return value; + } + } + } + + optimize_info_done(body_info); + + return form; +} + +/*========================================================================*/ +/* closures */ +/*========================================================================*/ + +static Scheme_Object * +optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int context) +{ + Scheme_Closure_Data *data; + Scheme_Object *code, *ctx; + Closure_Info *cl; + mzshort dcs, *dcm; + int i, cnt; + Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL; + + data = (Scheme_Closure_Data *)_data; + + info->single_result = 1; + info->preserves_marks = 1; + + info = optimize_info_add_frame(info, data->num_params, data->num_params, + SCHEME_LAMBDA_FRAME); + + info->vclock += 1; /* model delayed evaluation as vclock increment */ + + /* For reporting warnings: */ + if (info->context && SCHEME_PAIRP(info->context)) + ctx = scheme_make_pair((Scheme_Object *)data, + SCHEME_CDR(info->context)); + else if (info->context) + ctx = scheme_make_pair((Scheme_Object *)data, info->context); + else + ctx = (Scheme_Object *)data; + info->context = ctx; + + cl = (Closure_Info *)data->closure_map; + for (i = 0; i < data->num_params; i++) { + if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) + optimize_mutated(info, i); + + cnt = ((cl->local_flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); + if (cnt == 1) { + last_once_used = make_once_used(NULL, i, info->vclock, last_once_used); + if (!first_once_used) first_once_used = last_once_used; + optimize_propagate(info, i, (Scheme_Object *)last_once_used, 1); + } + } + + code = scheme_optimize_expr(data->code, info, 0); + + for (i = 0; i < data->num_params; i++) { + if (optimize_is_flonum_arg(info, i, 1)) + cl->local_flags[i] |= SCHEME_WAS_FLONUM_ARGUMENT; + } + + while (first_once_used) { + if (first_once_used->vclock < 0) { + /* no longer used once, due to binding propagation */ + cl->local_flags[first_once_used->pos] |= SCHEME_USE_COUNT_MASK; + } + first_once_used = first_once_used->next; + } + + if (info->single_result) + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SINGLE_RESULT; + else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT) + SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_SINGLE_RESULT; + + if (info->preserves_marks) + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_PRESERVES_MARKS; + else if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_PRESERVES_MARKS) + SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_PRESERVES_MARKS; + + if ((info->single_result > 0) && (info->preserves_marks > 0) + && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) + SCHEME_CLOSURE_DATA_FLAGS(data) -= CLOS_RESULT_TENTATIVE; + + data->code = code; + + /* Remembers positions of used vars (and unsets usage for this level) */ + env_make_closure_map(info, &dcs, &dcm); + cl->base_closure_size = dcs; + cl->base_closure_map = dcm; + if (env_uses_toplevel(info)) + cl->has_tl = 1; + else + cl->has_tl = 0; + cl->body_size = info->size; + cl->body_psize = info->psize; + cl->has_nonleaf = info->has_nonleaf; + + info->size++; + + data->closure_size = (cl->base_closure_size + + (cl->has_tl ? 1 : 0)); + + optimize_info_done(info); + + return (Scheme_Object *)data; +} + +static char *get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok) +{ + Closure_Info *cl = (Closure_Info *)data->closure_map; + + if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) + || (arg_n != data->num_params)) { + *ok = 0; + return NULL; + } + + if (cl->has_flomap && !cl->flonum_map) { + *ok = 0; + return NULL; + } + + *ok = 1; + return cl->flonum_map; +} + +static void set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map) +{ + Closure_Info *cl = (Closure_Info *)data->closure_map; + int i; + + if (!cl->flonum_map) { + cl->has_flomap = 1; + cl->flonum_map = flonum_map; + } + + if (flonum_map) { + for (i = data->num_params; i--; ) { + if (flonum_map[i]) break; + } + + if (i < 0) { + cl->flonum_map = NULL; + } + } +} + +static void merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2) +{ + Closure_Info *cl1 = (Closure_Info *)data1->closure_map; + Closure_Info *cl2 = (Closure_Info *)data2->closure_map; + + if (cl1->has_flomap) { + if (!cl1->flonum_map || !cl2->has_flomap) { + cl2->has_flomap = 1; + cl2->flonum_map = cl1->flonum_map; + } else if (cl2->flonum_map) { + int i; + for (i = data1->num_params; i--; ) { + if (cl1->flonum_map[i] != cl2->flonum_map[i]) { + cl2->flonum_map = NULL; + cl1->flonum_map = NULL; + break; + } + } + } else { + cl1->flonum_map = NULL; + } + } else if (cl2->has_flomap) { + cl1->has_flomap = 1; + cl1->flonum_map = cl2->flonum_map; + } +} + +static Scheme_Object *clone_closure_compilation(int dup_ok, Scheme_Object *_data, Optimize_Info *info, int delta, int closure_depth) +{ + Scheme_Closure_Data *data, *data2; + Scheme_Object *body; + Closure_Info *cl; + int *flags, sz; + char *flonum_map; + + data = (Scheme_Closure_Data *)_data; + + body = scheme_optimize_clone(dup_ok, data->code, info, delta, closure_depth + data->num_params); + if (!body) return NULL; + + data2 = MALLOC_ONE_TAGGED(Scheme_Closure_Data); + memcpy(data2, data, sizeof(Scheme_Closure_Data)); + + data2->code = body; + + cl = MALLOC_ONE_RT(Closure_Info); + memcpy(cl, data->closure_map, sizeof(Closure_Info)); + data2->closure_map = (mzshort *)cl; + + /* We don't have to update base_closure_map, because + it will get re-computed as the closure is re-optimized. */ + + sz = sizeof(int) * data2->num_params; + flags = (int *)scheme_malloc_atomic(sz); + memcpy(flags, cl->local_flags, sz); + cl->local_flags = flags; + + if (cl->flonum_map) { + sz = data2->num_params; + flonum_map = (char *)scheme_malloc_atomic(sz); + memcpy(flonum_map, cl->flonum_map, sz); + cl->flonum_map = flonum_map; + } + + return (Scheme_Object *)data2; +} + +static Scheme_Object *shift_closure_compilation(Scheme_Object *_data, int delta, int after_depth) +{ + Scheme_Object *expr; + Scheme_Closure_Data *data = (Scheme_Closure_Data *)_data; + + expr = scheme_optimize_shift(data->code, delta, after_depth + data->num_params); + data->code = expr; + + return _data; +} + +static int closure_body_size(Scheme_Closure_Data *data, int check_assign, + Optimize_Info *info, int *is_leaf) +{ + int i; + Closure_Info *cl; + + cl = (Closure_Info *)data->closure_map; + + if (check_assign) { + /* Don't try to inline if any arguments are mutated: */ + for (i = data->num_params; i--; ) { + if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) + return -1; + } + } + + if (is_leaf) + *is_leaf = !cl->has_nonleaf; + + return cl->body_size + ((info && info->use_psize) ? cl->body_psize : 0); +} + +static int closure_has_top_level(Scheme_Closure_Data *data) +{ + Closure_Info *cl; + + cl = (Closure_Info *)data->closure_map; + + return cl->has_tl; +} + +static int closure_argument_flags(Scheme_Closure_Data *data, int i) +{ + return ((Closure_Info *)data->closure_map)->local_flags[i]; +} + +/*========================================================================*/ +/* modules */ +/*========================================================================*/ + +static int set_code_closure_flags(Scheme_Object *clones, + int set_flags, int mask_flags, + int just_tentative) +{ + Scheme_Object *clone, *orig, *first; + Scheme_Closure_Data *data; + int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS; + + /* The first in a clone pair is the one that is consulted for + references. The second one is the original, and its the one whose + flags are updated by optimization. So consult the original, and set + flags in both. */ + + while (clones) { + first = SCHEME_CAR(clones); + clone = SCHEME_CAR(first); + orig = SCHEME_CDR(first); + + data = (Scheme_Closure_Data *)orig; + if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { + flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data)); + SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags); + data = (Scheme_Closure_Data *)clone; + SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags); + } + + clones = SCHEME_CDR(clones); + } + + return flags; +} + +static Scheme_Object * +module_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + Scheme_Module *m = (Scheme_Module *)data; + Scheme_Object *e, *vars, *old_context; + int start_simltaneous = 0, i_m, cnt; + Scheme_Object *cl_first = NULL, *cl_last = NULL; + Scheme_Hash_Table *consts = NULL, *ready_table = NULL, *re_consts = NULL; + int cont, next_pos_ready = -1, inline_fuel, is_proc_def; + + old_context = info->context; + info->context = (Scheme_Object *)m; + + cnt = SCHEME_VEC_SIZE(m->body); + + if (OPT_ESTIMATE_FUTURE_SIZES) { + if (info->enforce_const) { + /* For each identifier bound to a procedure, register an initial + size estimate, which is used to discourage early loop unrolling + at the expense of later inlining. */ + for (i_m = 0; i_m < cnt; i_m++) { + e = SCHEME_VEC_ELS(m->body)[i_m]; + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + int n; + + vars = SCHEME_VEC_ELS(e)[0]; + e = SCHEME_VEC_ELS(e)[1]; + + n = scheme_list_length(vars); + if (n == 1) { + if (IS_COMPILED_PROC(e)) { + Scheme_Toplevel *tl; + + tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + + if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + int pos; + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + pos = tl->position; + scheme_hash_set(consts, + scheme_make_integer(pos), + scheme_estimate_closure_size(e)); + } + } + } + } + } + + if (consts) { + info->top_level_consts = consts; + consts = NULL; + } + } + } + + for (i_m = 0; i_m < cnt; i_m++) { + /* Optimize this expression: */ + e = SCHEME_VEC_ELS(m->body)[i_m]; + + is_proc_def = 0; + if (OPT_DISCOURAGE_EARLY_INLINE && info->enforce_const) { + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + Scheme_Object *e2; + e2 = (Scheme_Object *)e; + e2 = SCHEME_VEC_ELS(e2)[1]; + if (IS_COMPILED_PROC(e2)) + is_proc_def = 1; + } + } + + if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { + info->use_psize = 1; + inline_fuel = info->inline_fuel; + if (inline_fuel > 2) + info->inline_fuel = 2; + } else + inline_fuel = 0; + e = scheme_optimize_expr(e, info, 0); + if (is_proc_def && OPT_DISCOURAGE_EARLY_INLINE) { + info->use_psize = 0; + info->inline_fuel = inline_fuel; + } + SCHEME_VEC_ELS(m->body)[i_m] = e; + + if (info->enforce_const) { + /* If this expression/definition can't have any side effect + (including raising an exception), then continue the group of + simultaneous definitions: */ + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + int n, cnst = 0, sproc = 0; + + vars = SCHEME_VEC_ELS(e)[0]; + e = SCHEME_VEC_ELS(e)[1]; + + n = scheme_list_length(vars); + cont = scheme_omittable_expr(e, n, -1, 0, info, -1); + + if (n == 1) { + if (scheme_compiled_propagate_ok(e, info)) + cnst = 1; + else if (scheme_is_statically_proc(e, info)) { + cnst = 1; + sproc = 1; + } + } + + if (cnst) { + Scheme_Toplevel *tl; + + tl = (Scheme_Toplevel *)SCHEME_CAR(vars); + + if (!(SCHEME_TOPLEVEL_FLAGS(tl) & SCHEME_TOPLEVEL_MUTATED)) { + Scheme_Object *e2; + + if (sproc) { + e2 = scheme_make_noninline_proc(e); + } else if (IS_COMPILED_PROC(e)) { + e2 = scheme_optimize_clone(1, e, info, 0, 0); + if (e2) { + Scheme_Object *pr; + pr = scheme_make_raw_pair(scheme_make_raw_pair(e2, e), NULL); + if (cl_last) + SCHEME_CDR(cl_last) = pr; + else + cl_first = pr; + cl_last = pr; + } else + e2 = scheme_make_noninline_proc(e); + } else { + e2 = e; + } + + if (e2) { + int pos; + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + pos = tl->position; + scheme_hash_set(consts, scheme_make_integer(pos), e2); + if (!re_consts) + re_consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(re_consts, scheme_make_integer(i_m), + scheme_make_integer(pos)); + } else { + /* At least mark it as ready */ + if (!ready_table) { + ready_table = scheme_make_hash_table(SCHEME_hash_ptr); + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table); + } + scheme_hash_set(ready_table, scheme_make_integer(tl->position), scheme_true); + } + } + } else { + /* The binding is not inlinable/propagatable, but unless it's + set!ed, it is constant after evaluating the definition. We + map the top-level position to indicate constantness. */ + Scheme_Object *l, *a; + int pos; + + for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + + /* Test for ISCONST to indicate no set!: */ + if (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED)) { + pos = SCHEME_TOPLEVEL_POS(a); + + next_pos_ready = pos; + } + } + } + } else { + cont = scheme_omittable_expr(e, -1, -1, 0, NULL, -1); + } + if (i_m + 1 == cnt) + cont = 0; + } else + cont = 1; + + if (!cont) { + /* If we have new constants, re-optimize to inline: */ + if (consts) { + int flags; + + if (!info->top_level_consts) { + info->top_level_consts = consts; + } else { + int i; + for (i = 0; i < consts->size; i++) { + if (consts->vals[i]) { + scheme_hash_set(info->top_level_consts, + consts->keys[i], + consts->vals[i]); + } + } + } + + /* Same as in letrec: assume CLOS_SINGLE_RESULT and + CLOS_PRESERVES_MARKS for all, but then assume not for all + if any turn out not (i.e., approximate fix point). */ + (void)set_code_closure_flags(cl_first, + CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, + 0xFFFF, + 0); + + while (1) { + /* Re-optimize this expression. We can optimize anything without + shift-cloning, since there are no local variables in scope. */ + int old_sz, new_sz; + + e = SCHEME_VEC_ELS(m->body)[start_simltaneous]; + + if (OPT_LIMIT_FUNCTION_RESIZE) { + if (SAME_TYPE(SCHEME_TYPE(e), scheme_define_values_type)) { + Scheme_Object *sub_e; + sub_e = SCHEME_VEC_ELS(e)[1]; + if (IS_COMPILED_PROC(sub_e)) + old_sz = scheme_compiled_proc_body_size(sub_e); + else + old_sz = 0; + } else + old_sz = 0; + } else + old_sz = 0; + + e = scheme_optimize_expr(e, info, 0); + SCHEME_VEC_ELS(m->body)[start_simltaneous] = e; + + if (re_consts) { + /* Install optimized closures into constant table --- + unless, maybe, they grow too much: */ + Scheme_Object *rpos; + rpos = scheme_hash_get(re_consts, scheme_make_integer(start_simltaneous)); + if (rpos) { + e = SCHEME_VEC_ELS(e)[1]; + if (!scheme_compiled_propagate_ok(e, info) + && scheme_is_statically_proc(e, info)) { + /* If we previously installed a procedure for inlining, + don't replace that with a worse approximation. */ + Scheme_Object *old_e; + old_e = scheme_hash_get(info->top_level_consts, rpos); + if (IS_COMPILED_PROC(old_e)) + e = NULL; + else + e = scheme_make_noninline_proc(e); + } + + if (e) { + if (OPT_LIMIT_FUNCTION_RESIZE) { + if (IS_COMPILED_PROC(e)) + new_sz = scheme_compiled_proc_body_size(e); + else + new_sz = 0; + } else + new_sz = 0; + + if (!new_sz || !old_sz || (new_sz < 4 * old_sz)) + scheme_hash_set(info->top_level_consts, rpos, e); + } + } + } + + if (start_simltaneous == i_m) + break; + start_simltaneous++; + } + + flags = set_code_closure_flags(cl_first, 0, 0xFFFF, 0); + (void)set_code_closure_flags(cl_first, + (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), + ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE), + 1); + } + + cl_last = cl_first = NULL; + consts = NULL; + re_consts = NULL; + start_simltaneous = i_m + 1; + } + + if (next_pos_ready > -1) { + if (!ready_table) { + ready_table = scheme_make_hash_table(SCHEME_hash_ptr); + if (!consts) + consts = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(consts, scheme_false, (Scheme_Object *)ready_table); + } + scheme_hash_set(ready_table, scheme_make_integer(next_pos_ready), scheme_true); + next_pos_ready = -1; + } + } + + /* Check one more time for expressions that we can omit: */ + { + int can_omit = 0; + for (i_m = 0; i_m < cnt; i_m++) { + /* Optimize this expression: */ + e = SCHEME_VEC_ELS(m->body)[i_m]; + if (scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { + can_omit++; + } + } + if (can_omit) { + Scheme_Object *vec; + int j = 0; + vec = scheme_make_vector(cnt - can_omit, NULL); + for (i_m = 0; i_m < cnt; i_m++) { + /* Optimize this expression: */ + e = SCHEME_VEC_ELS(m->body)[i_m]; + if (!scheme_omittable_expr(e, -1, -1, 0, NULL, -1)) { + SCHEME_VEC_ELS(vec)[j++] = e; + } + } + m->body = vec; + } + } + + info->context = old_context; + + /* Exp-time body was optimized during compilation */ + + return data; +} + +static Scheme_Object * +top_level_require_optimize(Scheme_Object *data, Optimize_Info *info, int context) +{ + return data; +} + + + +/*========================================================================*/ +/* expressions */ +/*========================================================================*/ + +static Scheme_Object *optimize_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1; + Optimize_Info *info = (Optimize_Info *)p->ku.k.p2; + int context = p->ku.k.i1; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + return scheme_optimize_expr(expr, info, context); +} + +Scheme_Object *scheme_optimize_expr(Scheme_Object *expr, Optimize_Info *info, int context) +{ + Scheme_Type type = SCHEME_TYPE(expr); + +#ifdef DO_STACK_CHECK +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + + p->ku.k.p1 = (void *)expr; + p->ku.k.p2 = (void *)info; + p->ku.k.i1 = context; + + return scheme_handle_stack_overflow(optimize_k); + } +#endif + + info->preserves_marks = 1; + info->single_result = 1; + + switch (type) { + case scheme_local_type: + { + Scheme_Object *val; + int pos, delta; + + info->size += 1; + + pos = SCHEME_LOCAL_POS(expr); + + val = optimize_info_lookup(info, pos, NULL, NULL, + (context & OPT_CONTEXT_NO_SINGLE) ? 0 : 1, + context, NULL); + + if (val) { + if (SAME_TYPE(SCHEME_TYPE(val), scheme_once_used_type)) { + Scheme_Once_Used *o = (Scheme_Once_Used *)val; + if ((o->vclock == info->vclock) + && single_valued_noncm_expression(o->expr, 5)) { + val = scheme_optimize_clone(1, o->expr, info, o->delta, 0); + if (val) { + info->size -= 1; + o->used = 1; + return scheme_optimize_expr(val, info, context); + } + } + /* Can't move expression, so lookup again to mark as used + and to perform any copy propagation that might apply. */ + val = optimize_info_lookup(info, pos, NULL, NULL, 0, context, NULL); + if (val) + return val; + } else { + if (SAME_TYPE(SCHEME_TYPE(val), scheme_compiled_toplevel_type)) { + info->size -= 1; + return scheme_optimize_expr(val, info, context); + } + return val; + } + } + + delta = optimize_info_get_shift(info, pos); + if (delta) + expr = scheme_make_local(scheme_local_type, pos + delta, 0); + + return expr; + } + case scheme_application_type: + return optimize_application(expr, info, context); + case scheme_application2_type: + return optimize_application2(expr, info, context); + case scheme_application3_type: + return optimize_application3(expr, info, context); + case scheme_sequence_type: + case scheme_splice_sequence_type: + return optimize_sequence(expr, info, context); + case scheme_branch_type: + return optimize_branch(expr, info, context); + case scheme_with_cont_mark_type: + return optimize_wcm(expr, info, context); + case scheme_compiled_unclosed_procedure_type: + return optimize_closure_compilation(expr, info, context); + case scheme_compiled_let_void_type: + return scheme_optimize_lets(expr, info, 0, context); + case scheme_compiled_toplevel_type: + info->size += 1; + if (info->top_level_consts) { + int pos; + Scheme_Object *c; + + while (1) { + pos = SCHEME_TOPLEVEL_POS(expr); + c = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); + c = scheme_no_potential_size(c); + if (c && SAME_TYPE(SCHEME_TYPE(c), scheme_compiled_toplevel_type)) + expr = c; + else + break; + } + + if (c) { + if (scheme_compiled_duplicate_ok(c)) + return c; + + /* We can't inline, but mark the top level as a constant, + so we can direct-jump and avoid null checks in JITed code: */ + expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_CONST); + } else { + /* false is mapped to a table of non-constant ready values: */ + c = scheme_hash_get(info->top_level_consts, scheme_false); + if (c) { + c = scheme_hash_get((Scheme_Hash_Table *)c, scheme_make_integer(pos)); + + if (c) { + /* We can't inline, but mark the top level as ready, + so we can avoid null checks in JITed code: */ + expr = scheme_toplevel_to_flagged_toplevel(expr, SCHEME_TOPLEVEL_READY); + } + } + if (!c) + info->vclock += 1; + } + } else { + info->vclock += 1; + } + optimize_info_used_top(info); + return expr; + case scheme_compiled_quote_syntax_type: + info->size += 1; + optimize_info_used_top(info); + return expr; + case scheme_variable_type: + case scheme_module_variable_type: + scheme_signal_error("got top-level in wrong place"); + return 0; + case scheme_define_values_type: + return define_values_optimize(expr, info, context); + case scheme_varref_form_type: + return ref_optimize(expr, info, context); + case scheme_set_bang_type: + return set_optimize(expr, info, context); + case scheme_define_syntaxes_type: + return define_syntaxes_optimize(expr, info, context); + case scheme_define_for_syntax_type: + return define_for_syntaxes_optimize(expr, info, context); + case scheme_case_lambda_sequence_type: + return case_lambda_optimize(expr, info, context); + case scheme_begin0_sequence_type: + return begin0_optimize(expr, info, context); + case scheme_apply_values_type: + return apply_values_optimize(expr, info, context); + case scheme_require_form_type: + return top_level_require_optimize(expr, info, context); + case scheme_module_type: + return module_optimize(expr, info, context); + default: + info->size += 1; + return expr; + } +} + +Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_Info *info, int delta, int closure_depth) +/* Past closure_depth, need to reverse optimize to unoptimzed with respect to info; + delta is the amount to skip in info to get to the frame that bound the code. + If dup_ok is 1, then the old copy will be dropped, so it's ok to "duplicate" + any constant. */ +{ + int t; + + t = SCHEME_TYPE(expr); + + switch(t) { + case scheme_local_type: + { + int pos = SCHEME_LOCAL_POS(expr); + if (pos >= closure_depth) { + expr = optimize_reverse(info, pos + delta - closure_depth, 0); + if (closure_depth) + expr = scheme_make_local(scheme_local_type, SCHEME_LOCAL_POS(expr) + closure_depth, 0); + } + return expr; + } + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr, *app2; + + app2 = MALLOC_ONE_TAGGED(Scheme_App2_Rec); + app2->iso.so.type = scheme_application2_type; + + expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth); + if (!expr) return NULL; + app2->rator = expr; + + expr = scheme_optimize_clone(dup_ok, app->rand, info, delta, closure_depth); + if (!expr) return NULL; + app2->rand = expr; + + return (Scheme_Object *)app2; + } + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)expr, *app2; + int i; + + app2 = scheme_malloc_application(app->num_args + 1); + + for (i = app->num_args + 1; i--; ) { + expr = scheme_optimize_clone(dup_ok, app->args[i], info, delta, closure_depth); + if (!expr) return NULL; + app2->args[i] = expr; + } + + return (Scheme_Object *)app2; + } + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr, *app2; + + app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec); + app2->iso.so.type = scheme_application3_type; + + expr = scheme_optimize_clone(dup_ok, app->rator, info, delta, closure_depth); + if (!expr) return NULL; + app2->rator = expr; + + expr = scheme_optimize_clone(dup_ok, app->rand1, info, delta, closure_depth); + if (!expr) return NULL; + app2->rand1 = expr; + + expr = scheme_optimize_clone(dup_ok, app->rand2, info, delta, closure_depth); + if (!expr) return NULL; + app2->rand2 = expr; + + return (Scheme_Object *)app2; + } + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *head = (Scheme_Let_Header *)expr, *head2; + Scheme_Object *body; + Scheme_Compiled_Let_Value *lv, *lv2, *prev = NULL; + int i, *flags, sz; + int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); + + head2 = MALLOC_ONE_TAGGED(Scheme_Let_Header); + head2->iso.so.type = scheme_compiled_let_void_type; + head2->count = head->count; + head2->num_clauses = head->num_clauses; + SCHEME_LET_FLAGS(head2) = SCHEME_LET_FLAGS(head); + + /* Build let-value change: */ + body = head->body; + for (i = head->num_clauses; i--; ) { + lv = (Scheme_Compiled_Let_Value *)body; + + sz = sizeof(int) * lv->count; + flags = (int *)scheme_malloc_atomic(sz); + memcpy(flags, lv->flags, sz); + + lv2 = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); + SCHEME_CLV_FLAGS(lv2) |= (SCHEME_CLV_FLAGS(lv) & 0x1); + lv2->iso.so.type = scheme_compiled_let_value_type; + lv2->count = lv->count; + lv2->position = lv->position; + lv2->flags = flags; + + expr = scheme_optimize_clone(dup_ok, lv->value, info, delta, + closure_depth + (post_bind ? 0 : head->count)); + if (!expr) return NULL; + lv2->value = expr; + + if (prev) + prev->body = (Scheme_Object *)lv2; + else + head2->body = (Scheme_Object *)lv2; + prev = lv2; + + body = lv->body; + } + if (prev) + prev->body = body; + else + head2->body = body; + + expr = scheme_optimize_clone(dup_ok, body, info, delta, closure_depth + head->count); + if (!expr) return NULL; + + if (prev) + prev->body = expr; + else + head2->body = expr; + + return (Scheme_Object *)head2; + } + case scheme_sequence_type: + case scheme_begin0_sequence_type: + case scheme_splice_sequence_type: + { + Scheme_Sequence *seq = (Scheme_Sequence *)expr, *seq2; + int i; + + seq2 = scheme_malloc_sequence(seq->count); + seq2->so.type = seq->so.type; + seq2->count = seq->count; + + for (i = seq->count; i--; ) { + expr = scheme_optimize_clone(dup_ok, seq->array[i], info, delta, closure_depth); + if (!expr) return NULL; + seq2->array[i] = expr; + } + + return (Scheme_Object *)seq2; + } + case scheme_branch_type: + { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr, *b2; + + b2 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); + b2->so.type = scheme_branch_type; + + expr = scheme_optimize_clone(dup_ok, b->test, info, delta, closure_depth); + if (!expr) return NULL; + b2->test = expr; + + expr = scheme_optimize_clone(dup_ok, b->tbranch, info, delta, closure_depth); + if (!expr) return NULL; + b2->tbranch = expr; + + expr = scheme_optimize_clone(dup_ok, b->fbranch, info, delta, closure_depth); + if (!expr) return NULL; + b2->fbranch = expr; + + return (Scheme_Object *)b2; + } + case scheme_with_cont_mark_type: + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr, *wcm2; + + wcm2 = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); + wcm2->so.type = scheme_with_cont_mark_type; + + expr = scheme_optimize_clone(dup_ok, wcm->key, info, delta, closure_depth); + if (!expr) return NULL; + wcm2->key = expr; + + expr = scheme_optimize_clone(dup_ok, wcm->val, info, delta, closure_depth); + if (!expr) return NULL; + wcm2->val = expr; + + expr = scheme_optimize_clone(dup_ok, wcm->body, info, delta, closure_depth); + if (!expr) return NULL; + wcm2->body = expr; + + return (Scheme_Object *)wcm2; + } + case scheme_compiled_unclosed_procedure_type: + return clone_closure_compilation(dup_ok, expr, info, delta, closure_depth); + case scheme_compiled_toplevel_type: + case scheme_compiled_quote_syntax_type: + return expr; + case scheme_define_values_type: + case scheme_define_syntaxes_type: + case scheme_define_for_syntax_type: + case scheme_boxenv_type: + return NULL; + case scheme_require_form_type: + return NULL; + case scheme_varref_form_type: + return NULL; + case scheme_set_bang_type: + return set_clone(dup_ok, expr, info, delta, closure_depth); + case scheme_apply_values_type: + return apply_values_clone(dup_ok, expr, info, delta, closure_depth); + case scheme_case_lambda_sequence_type: + return case_lambda_clone(dup_ok, expr, info, delta, closure_depth); + case scheme_module_type: + return NULL; + default: + if (t > _scheme_compiled_values_types_) { + if (dup_ok || scheme_compiled_duplicate_ok(expr)) + return expr; + } + } + + return NULL; +} + +Scheme_Object *scheme_optimize_shift(Scheme_Object *expr, int delta, int after_depth) +/* Shift lexical addresses deeper by delta if already deeper than after_depth; + can mutate. */ +{ + int t; + + /* FIXME: need stack check */ + + t = SCHEME_TYPE(expr); + + switch(t) { + case scheme_local_type: + case scheme_local_unbox_type: + { + int pos = SCHEME_LOCAL_POS(expr); + if (pos >= after_depth) { + expr = scheme_make_local(t, SCHEME_LOCAL_POS(expr) + delta, 0); + } + return expr; + } + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)expr; + int i; + + for (i = app->num_args + 1; i--; ) { + expr = scheme_optimize_shift(app->args[i], delta, after_depth); + app->args[i] = expr; + } + + return (Scheme_Object *)app; + } + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; + + expr = scheme_optimize_shift(app->rator, delta, after_depth); + app->rator = expr; + + expr = scheme_optimize_shift(app->rand, delta, after_depth); + app->rand = expr; + + return (Scheme_Object *)app; + } + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; + + expr = scheme_optimize_shift(app->rator, delta, after_depth); + app->rator = expr; + + expr = scheme_optimize_shift(app->rand1, delta, after_depth); + app->rand1 = expr; + + expr = scheme_optimize_shift(app->rand2, delta, after_depth); + app->rand2 = expr; + + return (Scheme_Object *)app; + } + case scheme_compiled_let_void_type: + { + Scheme_Let_Header *head = (Scheme_Let_Header *)expr; + Scheme_Object *body; + Scheme_Compiled_Let_Value *lv = NULL; + int i; + int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); + + /* Build let-value change: */ + body = head->body; + for (i = head->num_clauses; i--; ) { + lv = (Scheme_Compiled_Let_Value *)body; + + expr = scheme_optimize_shift(lv->value, delta, after_depth + (post_bind ? 0 : head->count)); + lv->value = expr; + + body = lv->body; + } + expr = scheme_optimize_shift(body, delta, after_depth + head->count); + + if (head->num_clauses) + lv->body = expr; + else + head->body = expr; + + return (Scheme_Object *)head; + } + case scheme_sequence_type: + case scheme_splice_sequence_type: + case scheme_begin0_sequence_type: + { + Scheme_Sequence *seq = (Scheme_Sequence *)expr; + int i; + + for (i = seq->count; i--; ) { + expr = scheme_optimize_shift(seq->array[i], delta, after_depth); + seq->array[i] = expr; + } + + return (Scheme_Object *)seq; + } + case scheme_branch_type: + { + Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)expr; + + expr = scheme_optimize_shift(b->test, delta, after_depth); + b->test = expr; + + expr = scheme_optimize_shift(b->tbranch, delta, after_depth); + b->tbranch = expr; + + expr = scheme_optimize_shift(b->fbranch, delta, after_depth); + b->fbranch = expr; + + return (Scheme_Object *)b; + } + case scheme_with_cont_mark_type: + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr; + + expr = scheme_optimize_shift(wcm->key, delta, after_depth); + wcm->key = expr; + + expr = scheme_optimize_shift(wcm->val, delta, after_depth); + wcm->val = expr; + + expr = scheme_optimize_shift(wcm->body, delta, after_depth); + wcm->body = expr; + + return (Scheme_Object *)wcm; + } + case scheme_compiled_unclosed_procedure_type: + return shift_closure_compilation(expr, delta, after_depth); + case scheme_compiled_toplevel_type: + case scheme_compiled_quote_syntax_type: + return expr; + case scheme_set_bang_type: + return set_shift(expr, delta, after_depth); + case scheme_varref_form_type: + return ref_shift(expr, delta, after_depth); + case scheme_apply_values_type: + return apply_values_shift(expr, delta, after_depth); + case scheme_case_lambda_sequence_type: + return case_lambda_shift(expr, delta, after_depth); + case scheme_boxenv_type: + case scheme_define_values_type: + case scheme_define_syntaxes_type: + case scheme_define_for_syntax_type: + case scheme_require_form_type: + case scheme_module_type: + scheme_signal_error("scheme_optimize_shift: no shift available for %d", SCHEME_TYPE(expr)); + return NULL; + default: + return expr; + } + + return NULL; +} + +/*========================================================================*/ +/* compile-time env for optimization */ +/*========================================================================*/ + +Optimize_Info *scheme_optimize_info_create() +{ + Optimize_Info *info; + + info = MALLOC_ONE_RT(Optimize_Info); +#ifdef MZTAG_REQUIRED + info->type = scheme_rt_optimize_info; +#endif + info->inline_fuel = 32; + + return info; +} + +void scheme_optimize_info_enforce_const(Optimize_Info *oi, int enforce_const) +{ + oi->enforce_const = enforce_const; +} + +void scheme_optimize_info_set_context(Optimize_Info *oi, Scheme_Object *ctx) +{ + oi->context = ctx; +} + +void scheme_optimize_info_never_inline(Optimize_Info *oi) +{ + oi->inline_fuel = -1; +} + +static void register_transitive_use(Optimize_Info *info, int pos, int j); + +static void register_stat_dist(Optimize_Info *info, int i, int j) +{ + if (!info->stat_dists) { + int k, *ia; + char **ca; + ca = MALLOC_N(char*, info->new_frame); + info->stat_dists = ca; + ia = MALLOC_N_ATOMIC(int, info->new_frame); + info->sd_depths = ia; + for (k = info->new_frame; k--; ) { + info->sd_depths[k] = 0; + } + } + + if (i >= info->new_frame) + scheme_signal_error("internal error: bad stat-dist index"); + + if (info->sd_depths[i] <= j) { + char *naya, *a; + int k; + + naya = MALLOC_N_ATOMIC(char, (j + 1)); + for (k = j + 1; k--; ) { + naya[k] = 0; + } + a = info->stat_dists[i]; + for (k = info->sd_depths[i]; k--; ) { + naya[k] = a[k]; + } + + info->stat_dists[i] = naya; + info->sd_depths[i] = j + 1; + } + + if (info->transitive_use && info->transitive_use[i]) { + /* We're using a procedure that we weren't sure would be used. + Transitively mark everything that the procedure uses --- unless + a transitive accumulation is in effect, in which case we + don't follow this one now, leaving it to be triggered when + the one we're accumulating is triggered. */ + if (!info->transitive_use_pos) { + mzshort *map = info->transitive_use[i]; + int len = info->transitive_use_len[i]; + int k; + + info->transitive_use[i] = NULL; + + for (k = 0; k < len; k++) { + register_transitive_use(info, map[k], 0); + } + } + } + + info->stat_dists[i][j] = 1; +} + +static Scheme_Object *transitive_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Optimize_Info *info = (Optimize_Info *)p->ku.k.p1; + + p->ku.k.p1 = NULL; + + register_transitive_use(info, (int)p->ku.k.i1, (int)p->ku.k.i2); + + return scheme_false; +} + +static void register_transitive_use(Optimize_Info *info, int pos, int j) +{ +#ifdef DO_STACK_CHECK +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + + p->ku.k.p1 = (void *)info; + p->ku.k.i1 = pos; + p->ku.k.i2 = j; + + scheme_handle_stack_overflow(transitive_k); + + return; + } +#endif + + while (info) { + if (info->flags & SCHEME_LAMBDA_FRAME) + j++; + if (pos < info->new_frame) + break; + pos -= info->new_frame; + info = info->next; + } + + if (info->sd_depths[pos] <= j) { + scheme_signal_error("bad transitive position depth: %d vs. %d", + info->sd_depths[pos], j); + } + + register_stat_dist(info, pos, j); +} + +static void env_make_closure_map(Optimize_Info *info, mzshort *_size, mzshort **_map) +{ + /* A closure map lists the captured variables for a closure; the + indices are resolved two new indices in the second phase of + compilation. */ + Optimize_Info *frame; + int i, j, pos = 0, lpos = 0, tu; + mzshort *map, size; + + /* Count vars used by this closure (skip args): */ + j = 1; + for (frame = info->next; frame; frame = frame->next) { + if (frame->flags & SCHEME_LAMBDA_FRAME) + j++; + + if (frame->stat_dists) { + for (i = 0; i < frame->new_frame; i++) { + if (frame->sd_depths[i] > j) { + if (frame->stat_dists[i][j]) { + pos++; + } + } + } + } + } + + size = pos; + *_size = size; + map = MALLOC_N_ATOMIC(mzshort, size); + *_map = map; + + if (info->next && info->next->transitive_use_pos) { + info->next->transitive_use[info->next->transitive_use_pos - 1] = map; + info->next->transitive_use_len[info->next->transitive_use_pos - 1] = size; + tu = 1; + } else + tu = 0; + + /* Build map, unmarking locals and marking deeper in parent frame */ + j = 1; pos = 0; + for (frame = info->next; frame; frame = frame->next) { + if (frame->flags & SCHEME_LAMBDA_FRAME) + j++; + + if (frame->stat_dists) { + for (i = 0; i < frame->new_frame; i++) { + if (frame->sd_depths[i] > j) { + if (frame->stat_dists[i][j]) { + map[pos++] = lpos; + frame->stat_dists[i][j] = 0; /* This closure's done with these vars... */ + if (!tu) + frame->stat_dists[i][j - 1] = 1; /* ... but ensure previous keeps */ + } + } + lpos++; + } + } else + lpos += frame->new_frame; + } +} + +static int env_uses_toplevel(Optimize_Info *frame) +{ + int used; + + used = frame->used_toplevel; + + if (used) { + /* Propagate use to an enclosing lambda, if any: */ + frame = frame->next; + while (frame) { + if (frame->flags & SCHEME_LAMBDA_FRAME) { + frame->used_toplevel = 1; + break; + } + frame = frame->next; + } + } + + return used; +} + +static void optimize_info_used_top(Optimize_Info *info) +{ + while (info) { + if (info->flags & SCHEME_LAMBDA_FRAME) { + info->used_toplevel = 1; + break; + } + info = info->next; + } +} + +static void optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use) +{ + /* A raw-pair `value' is an indicator for whether a letrec-bound + variable is ready. */ + Scheme_Object *p; + + p = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(p)[0] = info->consts; + SCHEME_VEC_ELS(p)[1] = scheme_make_integer(pos); + SCHEME_VEC_ELS(p)[2] = value; + SCHEME_VEC_ELS(p)[3] = (single_use ? scheme_true : scheme_false); + + info->consts = p; +} + +static Scheme_Once_Used *make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev) +{ + Scheme_Once_Used *o; + + o = MALLOC_ONE_TAGGED(Scheme_Once_Used); + o->so.type = scheme_once_used_type; + + o->expr = val; + o->pos = pos; + o->vclock = vclock; + + if (prev) + prev->next = o; + + return o; +} + +static void register_use(Optimize_Info *info, int pos, int flag) +/* pos must be in immediate frame */ +{ + if (!info->use) { + char *use; + use = (char *)scheme_malloc_atomic(info->new_frame); + memset(use, 0, info->new_frame); + info->use = use; + } + info->use[pos] |= flag; +} + +static void optimize_mutated(Optimize_Info *info, int pos) +/* pos must be in immediate frame */ +{ + register_use(info, pos, 0x1); +} + +static void optimize_produces_flonum(Optimize_Info *info, int pos) +/* pos must be in immediate frame */ +{ + register_use(info, pos, 0x4); +} + +static Scheme_Object *optimize_reverse(Optimize_Info *info, int pos, int unless_mutated) +/* pos is in new-frame counts, and we want to produce an old-frame reference if + it's not mutated */ +{ + int delta = 0; + + while (1) { + if (pos < info->new_frame) + break; + pos -= info->new_frame; + delta += info->original_frame; + info = info->next; + } + + if (unless_mutated) + if (info->use && (info->use[pos] & 0x1)) + return NULL; + + return scheme_make_local(scheme_local_type, pos + delta, 0); +} + +static int optimize_is_used(Optimize_Info *info, int pos) +/* pos must be in immediate frame */ +{ + int i; + + if (info->stat_dists) { + for (i = info->sd_depths[pos]; i--; ) { + if (info->stat_dists[pos][i]) + return 1; + } + } + + return 0; +} + +static int check_use(Optimize_Info *info, int pos, int flag) +/* pos is in new-frame counts */ +{ + while (1) { + if (pos < info->new_frame) + break; + pos -= info->new_frame; + info = info->next; + } + + if (info->use && (info->use[pos] & flag)) + return 1; + + return 0; +} + +static int optimize_is_mutated(Optimize_Info *info, int pos) +/* pos is in new-frame counts */ +{ + return check_use(info, pos, 0x1); +} + +static int optimize_is_flonum_arg(Optimize_Info *info, int pos, int depth) +/* pos is in new-frame counts */ +{ + return check_use(info, pos, 0x2); +} + +static int optimize_is_flonum_valued(Optimize_Info *info, int pos) +/* pos is in new-frame counts */ +{ + return check_use(info, pos, 0x4); +} + +static int optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos) +{ + int j, i; + + if (info->stat_dists) { + for (i = start_pos; i < end_pos; i++) { + for (j = info->sd_depths[i]; j--; ) { + if (info->stat_dists[i][j]) + return 1; + } + } + } + + if (info->transitive_use) { + for (i = info->new_frame; i--; ) { + if (info->transitive_use[i]) { + for (j = info->transitive_use_len[i]; j--; ) { + if ((info->transitive_use[i][j] >= start_pos) + && (info->transitive_use[i][j] < end_pos)) + return 1; + } + } + } + } + + return 0; +} + +static Scheme_Object *do_optimize_info_lookup(Optimize_Info *info, int pos, int j, int *closure_offset, int *single_use, + int *not_ready, int once_used_ok, int context, int *potential_size, + int disrupt_single_use) +{ + Scheme_Object *p, *n; + int delta = 0; + + while (info) { + if (info->flags & SCHEME_LAMBDA_FRAME) + j++; + if (pos < info->original_frame) + break; + pos -= info->original_frame; + delta += info->new_frame; + info = info->next; + } + + if (context & OPT_CONTEXT_FLONUM_ARG) + register_use(info, pos, 0x2); + + p = info->consts; + while (p) { + n = SCHEME_VEC_ELS(p)[1]; + if (SCHEME_INT_VAL(n) == pos) { + n = SCHEME_VEC_ELS(p)[2]; + if (info->flags & SCHEME_POST_BIND_FRAME) + delta += info->new_frame; + if (SCHEME_RPAIRP(n)) { + /* This was a letrec-bound identifier that may or may not be ready, + but which wasn't replaced with more information. */ + if (not_ready) + *not_ready = SCHEME_TRUEP(SCHEME_CAR(n)); + break; + } + if (SCHEME_BOXP(n)) { + /* A potential-size record: */ + if (potential_size) + *potential_size = (int)SCHEME_INT_VAL(SCHEME_BOX_VAL(n)); + break; + } + if (single_use) + *single_use = SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]); + if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_unclosed_procedure_type)) { + if (!closure_offset) + break; + else + *closure_offset = delta; + } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_case_lambda_sequence_type)) { + if (!closure_offset) + break; + else + *closure_offset = delta; + } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_compiled_toplevel_type)) { + /* Ok */ + } else if (closure_offset) { + /* Inlining can deal procedures and top-levels, but not other things. */ + return NULL; + } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_once_used_type)) { + Scheme_Once_Used *o; + + if (disrupt_single_use) { + ((Scheme_Once_Used *)n)->expr = NULL; + ((Scheme_Once_Used *)n)->vclock = -1; + } + + if (!once_used_ok) + break; + + o = (Scheme_Once_Used *)n; + if (!o->expr) break; /* disrupted or not available */ + + o->delta = delta; + o->info = info; + return (Scheme_Object *)o; + } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_local_type)) { + int pos; + + pos = SCHEME_LOCAL_POS(n); + if (info->flags & SCHEME_LAMBDA_FRAME) + j--; /* because it will get re-added on recur */ + else if (info->flags & SCHEME_POST_BIND_FRAME) + info = info->next; /* bindings are relative to next frame */ + + /* Marks local as used; we don't expect to get back + a value, because chaining would normally happen on the + propagate-call side. Chaining there also means that we + avoid stack overflow here. */ + if (single_use) { + if (!*single_use) + single_use = NULL; + } + + /* If the referenced variable is not single-use, then + the variable it is replaced by is no longer single-use */ + disrupt_single_use = !SCHEME_TRUEP(SCHEME_VEC_ELS(p)[3]); + + n = do_optimize_info_lookup(info, pos, j, NULL, single_use, NULL, + once_used_ok && !disrupt_single_use, context, + potential_size, disrupt_single_use); + + if (!n) { + /* Return shifted reference to other local: */ + delta += optimize_info_get_shift(info, pos); + n = scheme_make_local(scheme_local_type, pos + delta, 0); + } else if (SAME_TYPE(SCHEME_TYPE(n), scheme_once_used_type)) { + /* Need to adjust delta: */ + delta = optimize_info_get_shift(info, pos); + ((Scheme_Once_Used *)n)->delta += delta; + } + } + return n; + } + p = SCHEME_VEC_ELS(p)[0]; + } + + if (!closure_offset) + register_stat_dist(info, pos, j); + + return NULL; +} + +static Scheme_Object *optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use, + int once_used_ok, int context, int *potential_size) +{ + return do_optimize_info_lookup(info, pos, 0, closure_offset, single_use, NULL, once_used_ok, context, potential_size, 0); +} + +static int optimize_info_is_ready(Optimize_Info *info, int pos) +{ + int closure_offset, single_use, ready = 1; + + do_optimize_info_lookup(info, pos, 0, &closure_offset, &single_use, &ready, 0, 0, NULL, 0); + + return ready; +} + +static Optimize_Info *optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags) +{ + Optimize_Info *naya; + + naya = scheme_optimize_info_create(); + naya->flags = (short)flags; + naya->next = info; + naya->original_frame = orig; + naya->new_frame = current; + naya->inline_fuel = info->inline_fuel; + naya->letrec_not_twice = info->letrec_not_twice; + naya->enforce_const = info->enforce_const; + naya->top_level_consts = info->top_level_consts; + naya->context = info->context; + naya->vclock = info->vclock; + naya->use_psize = info->use_psize; + + return naya; +} + +static int optimize_info_get_shift(Optimize_Info *info, int pos) +{ + int delta = 0; + + while (info) { + if (pos < info->original_frame) + break; + pos -= info->original_frame; + delta += (info->new_frame - info->original_frame); + info = info->next; + } + + if (!info) + scheme_signal_error("error looking for local-variable offset"); + + return delta; +} + +static void optimize_info_done(Optimize_Info *info) +{ + info->next->size += info->size; + info->next->psize += info->psize; + info->next->vclock = info->vclock; + if (info->has_nonleaf) + info->next->has_nonleaf = 1; +} + +/*========================================================================*/ +/* precise GC traversers */ +/*========================================================================*/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#define MARKS_FOR_OPTIMIZE_C +#include "mzmark.c" + +static void register_traversers(void) +{ + GC_REG_TRAV(scheme_once_used_type, mark_once_used); + GC_REG_TRAV(scheme_rt_optimize_info, mark_optimize_info); +} + +END_XFORM_SKIP; + +#endif diff --git a/src/racket/src/places.c b/src/racket/src/place.c similarity index 100% rename from src/racket/src/places.c rename to src/racket/src/place.c diff --git a/src/racket/src/resolve.c b/src/racket/src/resolve.c new file mode 100644 index 0000000000..ce1ee11c76 --- /dev/null +++ b/src/racket/src/resolve.c @@ -0,0 +1,2908 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* This file implements the bytecode "resolve" pass, which converts + the optimization IR to the evaluation IR --- where the main + difference between the IRs is a change in stack addresses. This + pass is also reponsible for closure conversion (in the sense of + lifting closures that are used only in application positions were + all variabes captured by the closure can be converted to arguments + at all call sites). + + See "eval.c" for an overview of compilation passes. */ + +#include "schpriv.h" +#include "schrunst.h" +#include "schmach.h" + +struct Resolve_Info +{ + MZTAG_IF_REQUIRED + char use_jit, in_module, in_proc, enforce_const; + int size, oldsize, count, pos; + int max_let_depth; /* filled in by sub-expressions */ + Resolve_Prefix *prefix; + Scheme_Hash_Table *stx_map; /* compile offset => resolve offset; prunes prefix-recored stxes */ + mzshort toplevel_pos; /* -1 means consult `next' */ + void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */ + mzshort *old_pos; + mzshort *new_pos; + int stx_count; + mzshort *old_stx_pos; /* NULL => consult next; new pos is index in array */ + int *flags; + Scheme_Object **lifted; /* maps bindings to lifts */ + Scheme_Object *lifts; /* accumulates lift info */ + struct Resolve_Info *next; +}; + +#define cons(a,b) scheme_make_pair(a,b) + +static Scheme_Object * +resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, + int can_lift, int convert, int just_compute_lift, + Scheme_Object *precomputed_lift); +static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int oldsize, int mapcount); +static void resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted); +static void resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted); +static int resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted); +static int resolve_info_lookup(Resolve_Info *resolve, int pos, int *flags, Scheme_Object **lifted, int convert_shift); +static void resolve_info_set_toplevel_pos(Resolve_Info *info, int pos); +static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info); +static Scheme_Object *resolve_generate_stub_lift(void); +static int resolve_toplevel_pos(Resolve_Info *info); +static int resolve_is_toplevel_available(Resolve_Info *info); +static int resolve_quote_syntax_offset(int i, Resolve_Info *info); +static int resolve_quote_syntax_pos(Resolve_Info *info); +static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready); +static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info); +static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl); +static Scheme_Object *shift_toplevel(Scheme_Object *expr, int delta); +static int resolving_in_procedure(Resolve_Info *info); + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +void scheme_init_resolve() +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif +} + +/*========================================================================*/ +/* applications */ +/*========================================================================*/ + +static Scheme_Object *check_converted_rator(Scheme_Object *rator, Resolve_Info *info, Scheme_Object **new_rator, + int orig_arg_cnt, int *_rdelta) +{ + Scheme_Object *lifted; + int flags; + + if (!SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) + return NULL; + + (void)resolve_info_lookup(info, SCHEME_LOCAL_POS(rator), &flags, &lifted, orig_arg_cnt + 1); + + if (lifted && SCHEME_RPAIRP(lifted)) { + Scheme_Object *vec, *arity; + + *new_rator = SCHEME_CAR(lifted); + vec = SCHEME_CDR(lifted); + *_rdelta = 0; + + if (SCHEME_VEC_SIZE(vec) > 1) { + /* Check that actual argument count matches expected. If + it doesn't, we need to generate explicit code to report + the error, so that the conversion's arity change isn't + visible. */ + arity = SCHEME_VEC_ELS(vec)[0]; + if (SCHEME_INTP(arity)) { + if (orig_arg_cnt == SCHEME_INT_VAL(arity)) + arity = NULL; + } else { + arity = SCHEME_BOX_VAL(arity); + if (orig_arg_cnt >= SCHEME_INT_VAL(arity)) + arity = NULL; + else { + Scheme_App2_Rec *app; + app = MALLOC_ONE_TAGGED(Scheme_App2_Rec); + app->iso.so.type = scheme_application2_type; + app->rator = scheme_make_arity_at_least; + app->rand = arity; + arity = (Scheme_Object *)app; + *_rdelta = 1; /* so app gets resolved */ + } + } + /* If arity is non-NULL, there's a mismatch. */ + if (arity) { + /* Generate a call to `raise-arity-error' instead of + the current *new_rator: */ + Scheme_Object *old_rator = *new_rator; + if (SAME_TYPE(SCHEME_TYPE(old_rator), scheme_toplevel_type)) { + /* More coordinate trouble. old_rator was computed for an + application with a potentially different number of arguments. */ + int delta; + delta = 3 - SCHEME_VEC_SIZE(vec); + if (delta) + old_rator = shift_toplevel(old_rator, delta); + } + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(0); + SCHEME_VEC_ELS(vec)[1] = old_rator; + SCHEME_VEC_ELS(vec)[2] = arity; + *new_rator = scheme_raise_arity_error_proc; + } + } + + return vec; + } else + return NULL; +} + +static Scheme_Object *resolve_application(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count) +{ + Resolve_Info *info; + Scheme_App_Rec *app; + int i, n, devals; + + app = (Scheme_App_Rec *)o; + + n = app->num_args + 1; + + if (!already_resolved_arg_count) { + /* Check whether this is an application of a converted closure: */ + Scheme_Object *additions = NULL, *rator; + int rdelta; + additions = check_converted_rator(app->args[0], orig_info, &rator, n - 1, &rdelta); + if (additions) { + /* Expand application with m arguments */ + Scheme_App_Rec *app2; + Scheme_Object *loc; + int m; + m = SCHEME_VEC_SIZE(additions) - 1; + app2 = scheme_malloc_application(n + m); + for (i = 0; i < m; i++) { + loc = SCHEME_VEC_ELS(additions)[i+1]; + if (SCHEME_BOXP(loc)) + loc = SCHEME_BOX_VAL(loc); + else if (SCHEME_VECTORP(loc)) + loc = SCHEME_VEC_ELS(loc)[0]; + app2->args[i + 1] = loc; + } + for (i = 1; i < n; i++) { + app2->args[i + m] = app->args[i]; + } + app2->args[0] = rator; + n += m; + app = app2; + already_resolved_arg_count = m + 1 + rdelta; + } + } + + devals = sizeof(Scheme_App_Rec) + ((n - 1) * sizeof(Scheme_Object *)); + + info = resolve_info_extend(orig_info, n - 1, 0, 0); + + for (i = 0; i < n; i++) { + Scheme_Object *le; + if (already_resolved_arg_count) { + already_resolved_arg_count--; + } else { + le = scheme_resolve_expr(app->args[i], info); + app->args[i] = le; + } + } + + info->max_let_depth += (n - 1); + if (orig_info->max_let_depth < info->max_let_depth) + orig_info->max_let_depth = info->max_let_depth; + merge_resolve_tl_map(orig_info, info); + + for (i = 0; i < n; i++) { + char et; + et = scheme_get_eval_type(app->args[i]); + ((char *)app XFORM_OK_PLUS devals)[i] = et; + } + + return (Scheme_Object *)app; +} + +static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count); + +static void set_app2_eval_type(Scheme_App2_Rec *app) +{ + short et; + + et = scheme_get_eval_type(app->rand); + et = et << 3; + et += scheme_get_eval_type(app->rator); + + SCHEME_APPN_FLAGS(app) = et; +} + +void scheme_reset_app2_eval_type(Scheme_App2_Rec *app) +{ + set_app2_eval_type(app); +} + +static Scheme_Object *resolve_application2(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count) +{ + Resolve_Info *info; + Scheme_App2_Rec *app; + Scheme_Object *le; + + app = (Scheme_App2_Rec *)o; + + if (!already_resolved_arg_count) { + /* Check whether this is an application of a converted closure: */ + Scheme_Object *additions = NULL, *rator; + int rdelta; + additions = check_converted_rator(app->rator, orig_info, &rator, 1, &rdelta); + if (additions) { + int m; + m = SCHEME_VEC_SIZE(additions) - 1; + if (!m) { + app->rator = rator; + already_resolved_arg_count = 1 + rdelta; + } else if (m > 1) { + /* Expand application with m arguments */ + Scheme_App_Rec *app2; + Scheme_Object *loc; + int i; + app2 = scheme_malloc_application(2 + m); + for (i = 0; i < m; i++) { + loc = SCHEME_VEC_ELS(additions)[i+1]; + if (SCHEME_BOXP(loc)) + loc = SCHEME_BOX_VAL(loc); + else if (SCHEME_VECTORP(loc)) + loc = SCHEME_VEC_ELS(loc)[0]; + app2->args[i + 1] = loc; + } + app2->args[0] = rator; + app2->args[m+1] = app->rand; + return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta); + } else { + Scheme_App3_Rec *app2; + Scheme_Object *loc; + app2 = MALLOC_ONE_TAGGED(Scheme_App3_Rec); + app2->iso.so.type = scheme_application3_type; + app2->rator = rator; + loc = SCHEME_VEC_ELS(additions)[1]; + if (SCHEME_BOXP(loc)) + loc = SCHEME_BOX_VAL(loc); + else if (SCHEME_VECTORP(loc)) + loc = SCHEME_VEC_ELS(loc)[0]; + app2->rand1 = loc; + app2->rand2 = app->rand; + return resolve_application3((Scheme_Object *)app2, orig_info, 2 + rdelta); + } + } + } + + info = resolve_info_extend(orig_info, 1, 0, 0); + + if (!already_resolved_arg_count) { + le = scheme_resolve_expr(app->rator, info); + app->rator = le; + } else + already_resolved_arg_count--; + + if (!already_resolved_arg_count) { + le = scheme_resolve_expr(app->rand, info); + app->rand = le; + } else + already_resolved_arg_count--; + + info->max_let_depth += 1; + if (orig_info->max_let_depth < info->max_let_depth) + orig_info->max_let_depth = info->max_let_depth; + merge_resolve_tl_map(orig_info, info); + + set_app2_eval_type(app); + + return (Scheme_Object *)app; +} + +static int eq_testable_constant(Scheme_Object *v) +{ + if (SCHEME_SYMBOLP(v) + || SCHEME_FALSEP(v) + || SAME_OBJ(v, scheme_true) + || SCHEME_VOIDP(v)) + return 1; + + if (SCHEME_CHARP(v) && (SCHEME_CHAR_VAL(v) < 256)) + return 1; + + if (SCHEME_INTP(v) + && (SCHEME_INT_VAL(v) < (1 << 29)) + && (SCHEME_INT_VAL(v) > -(1 << 29))) + return 1; + + return 0; +} + +static void set_app3_eval_type(Scheme_App3_Rec *app) +{ + short et; + + et = scheme_get_eval_type(app->rand2); + et = et << 3; + et += scheme_get_eval_type(app->rand1); + et = et << 3; + et += scheme_get_eval_type(app->rator); + + SCHEME_APPN_FLAGS(app) = et; +} + +void scheme_reset_app3_eval_type(Scheme_App3_Rec *app) +{ + set_app3_eval_type(app); +} + +static Scheme_Object *resolve_application3(Scheme_Object *o, Resolve_Info *orig_info, int already_resolved_arg_count) +{ + Resolve_Info *info; + Scheme_App3_Rec *app; + Scheme_Object *le; + + app = (Scheme_App3_Rec *)o; + + if (!already_resolved_arg_count) { + /* Check whether this is an application of a converted closure: */ + Scheme_Object *additions = NULL, *rator; + int rdelta; + additions = check_converted_rator(app->rator, orig_info, &rator, 2, &rdelta); + if (additions) { + int m, i; + m = SCHEME_VEC_SIZE(additions) - 1; + if (m) { + /* Expand application with m arguments */ + Scheme_App_Rec *app2; + Scheme_Object *loc; + app2 = scheme_malloc_application(3 + m); + for (i = 0; i < m; i++) { + loc = SCHEME_VEC_ELS(additions)[i+1]; + if (SCHEME_BOXP(loc)) + loc = SCHEME_BOX_VAL(loc); + else if (SCHEME_VECTORP(loc)) + loc = SCHEME_VEC_ELS(loc)[0]; + app2->args[i + 1] = loc; + } + app2->args[0] = rator; + app2->args[m+1] = app->rand1; + app2->args[m+2] = app->rand2; + return resolve_application((Scheme_Object *)app2, orig_info, m + 1 + rdelta); + } else { + app->rator = rator; + already_resolved_arg_count = 1 + rdelta; + } + } + } + + info = resolve_info_extend(orig_info, 2, 0, 0); + + if (already_resolved_arg_count) { + already_resolved_arg_count--; + } else { + le = scheme_resolve_expr(app->rator, info); + app->rator = le; + } + + if (already_resolved_arg_count) { + already_resolved_arg_count--; + } else { + le = scheme_resolve_expr(app->rand1, info); + app->rand1 = le; + } + + if (already_resolved_arg_count) { + already_resolved_arg_count--; + } else { + le = scheme_resolve_expr(app->rand2, info); + app->rand2 = le; + } + + /* Optimize `equal?' or `eqv?' test on certain types + to `eq?'. This is especially helpful for the JIT. */ + if ((SAME_OBJ(app->rator, scheme_equal_prim) + || SAME_OBJ(app->rator, scheme_eqv_prim)) + && (eq_testable_constant(app->rand1) + || eq_testable_constant(app->rand2))) { + app->rator = scheme_eq_prim; + } + + set_app3_eval_type(app); + + info->max_let_depth += 2; + if (orig_info->max_let_depth < info->max_let_depth) + orig_info->max_let_depth = info->max_let_depth; + merge_resolve_tl_map(orig_info, info); + + return (Scheme_Object *)app; +} + +/*========================================================================*/ +/* branch, wcm */ +/*========================================================================*/ + +static Scheme_Object *resolve_branch(Scheme_Object *o, Resolve_Info *info) +{ + Scheme_Branch_Rec *b; + Scheme_Object *t, *tb, *fb; + + b = (Scheme_Branch_Rec *)o; + + t = scheme_resolve_expr(b->test, info); + tb = scheme_resolve_expr(b->tbranch, info); + fb = scheme_resolve_expr(b->fbranch, info); + + b->test = t; + b->tbranch = tb; + b->fbranch = fb; + + return o; +} + +static Scheme_Object *resolve_wcm(Scheme_Object *o, Resolve_Info *info) +{ + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; + Scheme_Object *k, *v, *b; + + k = scheme_resolve_expr(wcm->key, info); + v = scheme_resolve_expr(wcm->val, info); + b = scheme_resolve_expr(wcm->body, info); + wcm->key = k; + wcm->val = v; + wcm->body = b; + + return (Scheme_Object *)wcm; +} + +/*========================================================================*/ +/* sequences */ +/*========================================================================*/ + +static Scheme_Object *look_for_letv_change(Scheme_Sequence *s) +{ + int i; + + /* Change (begin e1 ... (set!-for-let [x 10] (void)) e2 ...) + to (begin e1 ... (set!-for-let [x 10] e2 ...)), which + avoids an unneeded recursive call in the evaluator */ + + for (i = 0; i < s->count - 1; i++) { + Scheme_Object *v; + v = s->array[i]; + if (SAME_TYPE(SCHEME_TYPE(v), scheme_let_value_type)) { + Scheme_Let_Value *lv = (Scheme_Let_Value *)v; + if (scheme_omittable_expr(lv->body, 1, -1, 0, NULL, -1)) { + int esize = s->count - (i + 1); + int nsize = i + 1; + Scheme_Object *nv, *ev; + + if (nsize > 1) { + Scheme_Sequence *naya; + + naya = scheme_malloc_sequence(nsize); + naya->so.type = s->so.type; + naya->count = nsize; + nv = (Scheme_Object *)naya; + + for (i = 0; i < nsize; i++) { + naya->array[i] = s->array[i]; + } + } else + nv = (Scheme_Object *)lv; + + if (esize > 1) { + Scheme_Sequence *e; + e = scheme_malloc_sequence(esize); + e->so.type = s->so.type; + e->count = esize; + + for (i = 0; i < esize; i++) { + e->array[i] = s->array[i + nsize]; + } + + ev = (Scheme_Object *)look_for_letv_change(e); + } else + ev = s->array[nsize]; + + lv->body = ev; + + return nv; + } + } + } + + return (Scheme_Object *)s; +} + +static Scheme_Object *resolve_sequence(Scheme_Object *o, Resolve_Info *info) +{ + Scheme_Sequence *s = (Scheme_Sequence *)o; + int i; + + for (i = s->count; i--; ) { + Scheme_Object *le; + le = scheme_resolve_expr(s->array[i], info); + s->array[i] = le; + } + + return look_for_letv_change(s); +} + +/*========================================================================*/ +/* other syntax */ +/*========================================================================*/ + +static Scheme_Object * +define_values_resolve(Scheme_Object *data, Resolve_Info *rslv) +{ + intptr_t cnt = 0; + Scheme_Object *vars = SCHEME_VEC_ELS(data)[0], *l, *a; + Scheme_Object *val = SCHEME_VEC_ELS(data)[1], *vec; + + /* If this is a module-level definition: for each variable, if the + defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then + resolve to a top-level reference with SCHEME_TOPLEVEL_CONST, so + that we know to set GLOS_IS_IMMUTATED at run time. */ + for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + if (rslv->in_module + && rslv->enforce_const + && (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) { + a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_CONST); + } + a = resolve_toplevel(rslv, a, 0); + SCHEME_CAR(l) = a; + cnt++; + } + + vec = scheme_make_vector(cnt + 1, NULL); + cnt = 1; + for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + SCHEME_VEC_ELS(vec)[cnt++] = SCHEME_CAR(l); + } + + val = scheme_resolve_expr(val, rslv); + SCHEME_VEC_ELS(vec)[0] = val; + + vec->type = scheme_define_values_type; + return vec; +} + +static void resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs) +{ + Scheme_Object *decl, *vec, *pr; + + vec = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(vec)[0] = rhs; + SCHEME_VEC_ELS(vec)[1] = var; + + vec->type = scheme_define_values_type; + + decl = vec; + + vec = info->lifts; + pr = cons(decl, SCHEME_VEC_ELS(vec)[0]); + SCHEME_VEC_ELS(vec)[0] = pr; +} + +static Scheme_Object * +set_resolve(Scheme_Object *data, Resolve_Info *rslv) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; + Scheme_Object *var, *val; + + var = sb->var; + val = sb->val; + + val = scheme_resolve_expr(val, rslv); + + if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { + Scheme_Let_Value *lv; + Scheme_Object *cv; + int flags, li; + + cv = scheme_compiled_void(); + + lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); + lv->iso.so.type = scheme_let_value_type; + lv->body = cv; + lv->count = 1; + li = resolve_info_lookup(rslv, SCHEME_LOCAL_POS(var), &flags, NULL, 0); + lv->position = li; + SCHEME_LET_AUTOBOX(lv) = (flags & SCHEME_INFO_BOXED); + lv->value = val; + + if (!(flags & SCHEME_INFO_BOXED)) + scheme_signal_error("internal error: set!: set!ed local variable is not boxed"); + + return (Scheme_Object *)lv; + } + + var = scheme_resolve_expr(var, rslv); + + sb->var = var; + sb->val = val; + + return (Scheme_Object *)sb; +} + +static Scheme_Object * +ref_resolve(Scheme_Object *data, Resolve_Info *rslv) +{ + Scheme_Object *v; + + v = scheme_resolve_expr(SCHEME_PTR1_VAL(data), rslv); + SCHEME_PTR1_VAL(data) = v; + v = scheme_resolve_expr(SCHEME_PTR2_VAL(data), rslv); + SCHEME_PTR2_VAL(data) = v; + + return data; +} + +static Scheme_Object * +apply_values_resolve(Scheme_Object *data, Resolve_Info *rslv) +{ + Scheme_Object *f, *e; + + f = SCHEME_PTR1_VAL(data); + e = SCHEME_PTR2_VAL(data); + + f = scheme_resolve_expr(f, rslv); + e = scheme_resolve_expr(e, rslv); + + SCHEME_PTR1_VAL(data) = f; + SCHEME_PTR2_VAL(data) = e; + + return data; +} + +static Scheme_Object * +case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv) +{ + int i, all_closed = 1; + Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; + + for (i = 0; i < seq->count; i++) { + Scheme_Object *le; + le = seq->array[i]; + le = resolve_closure_compilation(le, rslv, 0, 0, 0, NULL); + seq->array[i] = le; + if (!SCHEME_PROCP(le)) + all_closed = 0; + } + + if (all_closed) { + /* Produce closure directly */ + return scheme_case_lambda_execute(expr); + } + + return expr; +} + +static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info, int for_stx) +{ + Comp_Prefix *cp; + Resolve_Prefix *rp; + Scheme_Object *names, *val, *base_stack_depth, *dummy, *vec; + Resolve_Info *einfo; + int len; + + cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; + dummy = SCHEME_VEC_ELS(data)[1]; + names = SCHEME_VEC_ELS(data)[2]; + val = SCHEME_VEC_ELS(data)[3]; + + rp = scheme_resolve_prefix(1, cp, 1); + + dummy = scheme_resolve_expr(dummy, info); + + einfo = scheme_resolve_info_create(rp); + + if (for_stx) + names = scheme_resolve_list(names, einfo); + val = scheme_resolve_expr(val, einfo); + + rp = scheme_remap_prefix(rp, einfo); + + base_stack_depth = scheme_make_integer(einfo->max_let_depth); + + len = scheme_list_length(names); + + vec = scheme_make_vector(len + 4, NULL); + SCHEME_VEC_ELS(vec)[0] = val; + SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; + SCHEME_VEC_ELS(vec)[2] = base_stack_depth; + SCHEME_VEC_ELS(vec)[3] = dummy; + + len = 4; + while (SCHEME_PAIRP(names)) { + SCHEME_VEC_ELS(vec)[len++] = SCHEME_CAR(names); + names = SCHEME_CDR(names); + } + + vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + + return vec; +} + +static Scheme_Object *define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) +{ + return do_define_syntaxes_resolve(data, info, 0); +} + +static Scheme_Object *define_for_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) +{ + return do_define_syntaxes_resolve(data, info, 1); +} + +/*========================================================================*/ +/* let, let-values, letrec, etc. */ +/*========================================================================*/ + +static int is_lifted_reference(Scheme_Object *v) +{ + if (SCHEME_RPAIRP(v)) + return 1; + + return (SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type) + && (SCHEME_TOPLEVEL_FLAGS(v) & SCHEME_TOPLEVEL_CONST)); +} + +static int is_closed_reference(Scheme_Object *v) +{ + /* Look for a converted function (possibly with no new arguments) + that is accessed directly as a closure, instead of through a + top-level reference. */ + if (SCHEME_RPAIRP(v)) { + v = SCHEME_CAR(v); + return SCHEME_PROCP(v); + } + + return 0; +} + +static Scheme_Object *scheme_resolve_generate_stub_closure() +{ + Scheme_Closure *cl; + Scheme_Object **ca; + + cl = scheme_malloc_empty_closure(); + + ca = MALLOC_N(Scheme_Object*, 4); + ca[0] = scheme_make_integer(0); + ca[1] = NULL; + ca[2] = scheme_make_integer(0); + ca[3] = NULL; + + return scheme_make_raw_pair((Scheme_Object *)cl, (Scheme_Object *)ca); +} + +static void shift_lift(Scheme_Object *lifted, int frame_size, int lifted_frame_size) +{ + int i, cnt, delta; + Scheme_Object **ca; + mzshort *map; + + if (!lifted) return; + if (!SCHEME_RPAIRP(lifted)) return; + + ca = (Scheme_Object **)SCHEME_CDR(lifted); + cnt = SCHEME_INT_VAL(ca[0]); + map = (mzshort *)ca[1]; + + delta = (frame_size - lifted_frame_size); + + for (i = 0; i < cnt; i++) { + map[i] += delta; + } +} + +static int get_convert_arg_count(Scheme_Object *lift) +{ + if (!lift) + return 0; + else if (SCHEME_RPAIRP(lift)) { + Scheme_Object **ca; + ca = (Scheme_Object **)SCHEME_CDR(lift); + return SCHEME_INT_VAL(ca[0]); + } else + return 0; +} + +static Scheme_Object *drop_zero_value_return(Scheme_Object *expr) +{ + if (SAME_TYPE(SCHEME_TYPE(expr), scheme_sequence_type)) { + if (((Scheme_Sequence *)expr)->count == 2) { + if (SAME_TYPE(SCHEME_TYPE(((Scheme_Sequence *)expr)->array[1]), scheme_application_type)) { + if (((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->num_args == 0) { + if (SAME_OBJ(scheme_values_func, ((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->args[0])) { + return ((Scheme_Sequence *)expr)->array[0]; + } + } + } + } + } + + return NULL; +} + +Scheme_Object * +scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) +{ + Resolve_Info *linfo, *val_linfo = NULL; + Scheme_Let_Header *head = (Scheme_Let_Header *)form; + Scheme_Compiled_Let_Value *clv, *pre_body; + Scheme_Let_Value *lv, *last = NULL; + Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL; + Scheme_Letrec *letrec; + mzshort *skips, skips_fast[5]; + char *flonums, flonums_fast[5]; + Scheme_Object **lifted, *lifted_fast[5], *boxes; + int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc; + int rec_proc_nonapply = 0; + int max_let_depth = 0; + int resolve_phase, num_skips; + Scheme_Object **lifted_recs; + int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); + + /* Find body: */ + body = head->body; + pre_body = NULL; + for (i = head->num_clauses; i--; ) { + pre_body = (Scheme_Compiled_Let_Value *)body; + body = pre_body->body; + } + + recbox = 0; + if (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) { + /* Do we need to box vars in a letrec? */ + clv = (Scheme_Compiled_Let_Value *)head->body; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + int is_proc, is_lift; + + if ((clv->count == 1) + && !(clv->flags[0] & SCHEME_WAS_USED)) { + /* skip */ + } else { + if (clv->count == 1) + is_proc = scheme_is_compiled_procedure(clv->value, 1, 1); + else + is_proc = 0; + + if (is_proc) + is_lift = 0; + else if (SCHEME_CLV_FLAGS(clv) & SCHEME_CLV_NO_GROUP_USES) + is_lift = 1; + else + is_lift = scheme_is_liftable(clv->value, head->count, 5, 1); + + if (!is_proc && !is_lift) { + recbox = 1; + break; + } else { + if (!is_lift) { + /* is_proc must be true ... */ + int j; + + for (j = 0; j < clv->count; j++) { + if (clv->flags[j] & SCHEME_WAS_SET_BANGED) { + recbox = 1; + break; + } + } + if (recbox) + break; + + if (scheme_is_compiled_procedure(clv->value, 0, 0)) { + num_rec_procs++; + if (!(clv->flags[0] & SCHEME_WAS_ONLY_APPLIED)) + rec_proc_nonapply = 1; + } + } + } + } + } + + if (recbox) + num_rec_procs = 0; + } else { + /* Sequence of single-value, non-assigned lets? */ + int some_used = 0; + + clv = (Scheme_Compiled_Let_Value *)head->body; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + if (clv->count != 1) + break; + if (clv->flags[0] & SCHEME_WAS_SET_BANGED) + break; + if (clv->flags[0] & SCHEME_WAS_USED) + some_used = 1; + } + + if (i < 0) { + /* Yes - build chain of Scheme_Let_Ones and we're done: */ + int skip_count = 0, frame_size, lifts_frame_size = 0; + int j, k, n, rev_bind_order = 0; + + if (head->num_clauses > 1) { + clv = (Scheme_Compiled_Let_Value *)head->body; + if (clv->position > ((Scheme_Compiled_Let_Value *)clv->body)->position) + rev_bind_order = 1; + } + + j = head->num_clauses; + if (j <= 5) { + skips = skips_fast; + lifted = lifted_fast; + flonums = flonums_fast; + } else { + skips = MALLOC_N_ATOMIC(mzshort, j); + lifted = MALLOC_N(Scheme_Object*, j); + flonums = MALLOC_N_ATOMIC(char, j); + } + + clv = (Scheme_Compiled_Let_Value *)head->body; + for (i = 0; i < j; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) { + if (!(clv->flags[0] & SCHEME_WAS_USED)) + skips[i] = 1; + else + skips[i] = 0; + if ((clv->flags[0] & SCHEME_WAS_FLONUM_ARGUMENT) + && scheme_expr_produces_flonum(clv->value)) + flonums[i] = SCHEME_INFO_FLONUM_ARG; + else + flonums[i] = 0; + lifted[i] = NULL; + } + + clv = (Scheme_Compiled_Let_Value *)head->body; + for (i = 0; i < head->num_clauses; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) { + Scheme_Object *le; + + if (!(clv->flags[0] & SCHEME_WAS_USED)) { + skip_count++; + } + + /* First `i+1' bindings now exist "at runtime", except those skipped. */ + /* The mapping is complicated because we now push in the order of + the variables, but it may have been compiled using the inverse order. */ + frame_size = i + 1 - skip_count; + if (lifts_frame_size != frame_size) { + /* We need to shift coordinates for any lifted[j] that is a + converted procedure. */ + for (j = i, k = 0; j >= 0; j--) { + shift_lift(lifted[j], frame_size, lifts_frame_size); + } + } + if (post_bind) { + linfo = resolve_info_extend(info, frame_size, 0, 0); + } else { + linfo = resolve_info_extend(info, frame_size, head->count, i + 1); + for (j = i, k = 0; j >= 0; j--) { + n = (rev_bind_order ? (head->count - j - 1) : j); + if (skips[j]) + resolve_info_add_mapping(linfo, n, -1, flonums[j], lifted[j]); + else + resolve_info_add_mapping(linfo, n, k++, flonums[j], lifted[j]); + } + } + lifts_frame_size = frame_size; + + if (skips[i]) { + le = scheme_void; + } else { + if ((clv->flags[0] & SCHEME_WAS_ONLY_APPLIED) + && SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_unclosed_procedure_type)) + le = resolve_closure_compilation(clv->value, linfo, 1, 1, 0, NULL); + else + le = scheme_resolve_expr(clv->value, linfo); + } + + if (max_let_depth < linfo->max_let_depth + frame_size) + max_let_depth = linfo->max_let_depth + frame_size; + merge_resolve_tl_map(info, linfo); + + if (is_lifted_reference(le)) { + lifted[i] = le; + + /* At this point, it's ok to change our mind + about skipping, because compilation for previous + RHSs did not look at this one. */ + if (!skips[i]) { + skips[i] = 1; + skip_count++; + } + } + + if (skips[i]) { + /* Unused binding, so drop it. */ + } else { + Scheme_Let_One *lo; + int et; + + lo = MALLOC_ONE_TAGGED(Scheme_Let_One); + lo->iso.so.type = scheme_let_one_type; + lo->value = le; + + et = scheme_get_eval_type(lo->value); + if (flonums[i]) + et |= LET_ONE_FLONUM; + SCHEME_LET_EVAL_TYPE(lo) = et; + + if (last) + ((Scheme_Let_One *)last)->body = (Scheme_Object *)lo; + else + first = (Scheme_Object *)lo; + last = (Scheme_Let_Value *)lo; + } + } + + frame_size = head->count - skip_count; + linfo = resolve_info_extend(info, frame_size, head->count, head->count); + + if (lifts_frame_size != frame_size) { + for (i = head->count; i--; ) { + /* We need to shift coordinates for any lifted[j] that is a + converted procedure. */ + shift_lift(lifted[i], frame_size, lifts_frame_size); + } + } + + for (k = 0, i = head->count; i--; ) { + n = (rev_bind_order ? (head->count - i - 1) : i); + if ((skips[i] != 0) && (skips[i] != 1)) scheme_signal_error("trashed\n"); + if (skips[i]) + resolve_info_add_mapping(linfo, n, -1, flonums[i], lifted[i]); + else + resolve_info_add_mapping(linfo, n, k++, flonums[i], lifted[i]); + } + + body = scheme_resolve_expr(body, linfo); + if (last) + ((Scheme_Let_One *)last)->body = body; + else { + first = body; + } + + if (max_let_depth < linfo->max_let_depth + frame_size) + max_let_depth = linfo->max_let_depth + frame_size; + + if (info->max_let_depth < max_let_depth) + info->max_let_depth = max_let_depth; + + merge_resolve_tl_map(info, linfo); + + /* Check for (let ([x ]) ( x)) at end, and change to + ( ). This transformation is more generally performed + at the optimization layer, the cocde here pre-dates the mode general + optimzation, and we keep it just in case. The simple case is easy here, + because the local-variable offsets in do not change (as long as + doesn't access the stack). */ + last_body = NULL; + body = first; + while (1) { + if (!SAME_TYPE(SCHEME_TYPE(body), scheme_let_one_type)) + break; + if (!SAME_TYPE(SCHEME_TYPE(((Scheme_Let_One *)body)->body), scheme_let_one_type)) + break; + last_body = body; + body = ((Scheme_Let_One *)body)->body; + } + if (SAME_TYPE(SCHEME_TYPE(body), scheme_let_one_type)) { + if (SAME_TYPE(SCHEME_TYPE(((Scheme_Let_One *)body)->body), scheme_application2_type)) { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)((Scheme_Let_One *)body)->body; + if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type) + && (SCHEME_LOCAL_POS(app->rand) == 1)) { + if ((SCHEME_TYPE(app->rator) > _scheme_values_types_) + && !scheme_wants_flonum_arguments(app->rator, 0, 1)) { + /* Move to app, and drop let-one: */ + app->rand = ((Scheme_Let_One *)body)->value; + scheme_reset_app2_eval_type(app); + if (last_body) + ((Scheme_Let_One *)last_body)->body = (Scheme_Object *)app; + else + first = (Scheme_Object *)app; + } + } + } + } + + return first; + } else { + /* Maybe some multi-binding lets, but all of them are unused + and the RHSes are omittable? This can happen with auto-generated + code. */ + int total = 0, j; + + clv = (Scheme_Compiled_Let_Value *)head->body; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + total += clv->count; + for (j = clv->count; j--; ) { + if (clv->flags[j] & SCHEME_WAS_USED) + break; + } + if (j >= 0) + break; + if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL, -1)) + break; + } + if (i < 0) { + /* All unused and omittable */ + linfo = resolve_info_extend(info, 0, total, 0); + first = scheme_resolve_expr((Scheme_Object *)clv, linfo); + if (info->max_let_depth < linfo->max_let_depth) + info->max_let_depth = linfo->max_let_depth; + merge_resolve_tl_map(info, linfo); + return first; + } + } + } + + num_skips = 0; + clv = (Scheme_Compiled_Let_Value *)head->body; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) + num_skips++; + } + + /* First assume that all letrec-bound procedures can be lifted to empty closures. + Then try assuming that all letrec-bound procedures can be at least lifted. + Then fall back to assuming no lifts. */ + + linfo = 0; + for (resolve_phase = ((num_rec_procs && !rec_proc_nonapply) ? 0 : 2); resolve_phase < 3; resolve_phase++) { + + /* Don't try plain lifting if top level is not available: */ + if ((resolve_phase == 1) && !resolve_is_toplevel_available(info)) + resolve_phase = 2; + + if (resolve_phase < 2) { + linfo = resolve_info_extend(info, head->count - num_rec_procs - num_skips, head->count, head->count); + lifted_recs = MALLOC_N(Scheme_Object *, num_rec_procs); + } else { + linfo = resolve_info_extend(info, head->count - num_skips, head->count, head->count); + lifted_recs = NULL; + } + + if (post_bind) + val_linfo = resolve_info_extend(info, head->count - num_skips, 0, 0); + else + val_linfo = linfo; + + /* Build mapping of compile-time indices to run-time indices, shuffling + letrecs to fall together in the shallowest part. Also determine + and initialize lifts for recursive procedures. Generating lift information + requires an iteration. */ + clv = (Scheme_Compiled_Let_Value *)head->body; + pos = ((resolve_phase < 2) ? 0 : num_rec_procs); + rpos = 0; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + int j; + + opos = clv->position; + + if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { + /* skipped */ + resolve_info_add_mapping(linfo, opos, 0, 0, NULL); + } else { + for (j = 0; j < clv->count; j++) { + int p, skip; + Scheme_Object *lift; + + skip = 0; + if (num_rec_procs + && (clv->count == 1) + && scheme_is_compiled_procedure(clv->value, 0, 0)) { + if (resolve_phase == 0) { + lift = scheme_resolve_generate_stub_closure(); + lifted_recs[rpos] = lift; + p = 0; + } else if (resolve_phase == 1) { + lift = resolve_generate_stub_lift(); + lifted_recs[rpos] = lift; + p = 0; + } else { + lift = NULL; + p = rpos; + } + rpos++; + } else { + p = pos++; + lift = NULL; + } + + resolve_info_add_mapping(linfo, opos, p, + ((recbox + || (clv->flags[j] & SCHEME_WAS_SET_BANGED)) + ? SCHEME_INFO_BOXED + : 0), + lift); + + opos++; + } + } + } + + if (resolve_phase < 2) { + /* Given the assumption that all are closed/lifted, compute + actual lift info. We have to iterate if there are + conversions, because a conversion can trigger another + conversion. If the conversion changes for an item, it's + always by adding more conversion arguments. */ + int converted; + do { + clv = (Scheme_Compiled_Let_Value *)head->body; + rpos = 0; + converted = 0; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + opos = clv->position; + if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { + /* skipped */ + } else if ((clv->count == 1) + && scheme_is_compiled_procedure(clv->value, 0, 0)) { + Scheme_Object *lift, *old_lift; + int old_convert_count; + + old_lift = lifted_recs[rpos]; + old_convert_count = get_convert_arg_count(old_lift); + + lift = resolve_closure_compilation(clv->value, val_linfo, 1, 1, 1, + (resolve_phase ? NULL : old_lift)); + + if (is_closed_reference(lift) + || (is_lifted_reference(lift) && resolve_phase)) { + if (!SAME_OBJ(old_lift, lift)) + resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift); + lifted_recs[rpos] = lift; + if (get_convert_arg_count(lift) != old_convert_count) + converted = 1; + } else { + lifted_recs = NULL; + converted = 0; + break; + } + rpos++; + } + } + } while (converted); + + if (lifted_recs) { + /* All can be closed or lifted --- and some may be converted. + For the converted ones, the argument conversion is right. For + lifted ones, we need to generate the actual offset. For fully + closed ones, we need the actual closure. + + If we succeeded with resolve_phase == 0, then all can be + fully closed. We need to resolve again with the stub + closures in place, and the mutate the stub closures with + the actual closure info. + + If we succeeded with resolve_phase == 1, then we need + actual lift offsets before resolving procedure bodies. + Also, we need to fix up the stub closures. */ + clv = (Scheme_Compiled_Let_Value *)head->body; + rpos = 0; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + opos = clv->position; + if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { + /* skipped */ + } else if ((clv->count == 1) && scheme_is_compiled_procedure(clv->value, 0, 0)) { + Scheme_Object *lift; + lift = lifted_recs[rpos]; + if (is_closed_reference(lift)) { + (void)resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lift); + /* lift is the final result; this result might be + referenced in the body of closures already, or in + not-yet-closed functions. If no one uses the result + via linfo, then the code was dead and it will get + GCed. */ + clv->value = NULL; /* inidicates that there's nothing more to do with the expr */ + } else { + lift = resolve_closure_compilation(clv->value, val_linfo, 1, 1, 2, NULL); + /* need to resolve one more time for the body of the lifted function */ + } + resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift); + lifted_recs[rpos] = lift; + rpos++; + } + } + + break; /* don't need to iterate */ + } + } + } + + extra_alloc = 0; + + if (num_rec_procs) { + if (!lifted_recs) { + Scheme_Object **sa; + letrec = MALLOC_ONE_TAGGED(Scheme_Letrec); + letrec->so.type = scheme_letrec_type; + letrec->count = num_rec_procs; + sa = MALLOC_N(Scheme_Object *, num_rec_procs); + letrec->procs = sa; + } else { + extra_alloc = -num_rec_procs; + letrec = NULL; + } + } else + letrec = NULL; + + /* Resolve values: */ + boxes = scheme_null; + clv = (Scheme_Compiled_Let_Value *)head->body; + rpos = 0; + for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { + opos = clv->position; + if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { + /* skipped */ + } else { + int isproc; + Scheme_Object *expr; + if (!clv->value) + isproc = 1; + else if (clv->count == 1) + isproc = scheme_is_compiled_procedure(clv->value, 0, 0); + else + isproc = 0; + if (num_rec_procs && isproc) { + if (!lifted_recs) { + expr = resolve_closure_compilation(clv->value, val_linfo, 0, 0, 0, NULL); + letrec->procs[rpos++] = expr; + } else { + if (!is_closed_reference(lifted_recs[rpos])) { + /* Side-effect is to install lifted function: */ + (void)resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lifted_recs[rpos]); + } + rpos++; + } + } else { + int j; + Scheme_Object *one_lifted; + + if (!clv->count) + expr = drop_zero_value_return(clv->value); + else + expr = NULL; + + if (expr) { + /* Change a `[() (begin expr (values))]' clause, + which can be generated by internal-definition expansion, + into a `begin' */ + expr = scheme_resolve_expr(expr, val_linfo); + expr = scheme_make_sequence_compilation(scheme_make_pair(expr, + scheme_make_pair(scheme_false, + scheme_null)), + 0); + + if (last) + last->body = expr; + else if (last_body) + SCHEME_PTR2_VAL(last_body) = expr; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = expr; + else + first = expr; + last = NULL; + last_body = NULL; + last_seq = expr; + } else { + expr = scheme_resolve_expr(clv->value, val_linfo); + + lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); + if (last) + last->body = (Scheme_Object *)lv; + else if (last_body) + SCHEME_PTR2_VAL(last_body) = (Scheme_Object *)lv; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)lv; + else + first = (Scheme_Object *)lv; + last = lv; + last_body = NULL; + last_seq = NULL; + + lv->iso.so.type = scheme_let_value_type; + lv->value = expr; + if (clv->count) { + int li; + li = resolve_info_lookup(linfo, clv->position, NULL, NULL, 0); + lv->position = li; + } else + lv->position = 0; + lv->count = clv->count; + SCHEME_LET_AUTOBOX(lv) = recbox; + + for (j = lv->count; j--; ) { + if (!recbox + && (resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) { + GC_CAN_IGNORE Scheme_Object *pos; + pos = scheme_make_integer(lv->position + j); + if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) { + /* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */ + Scheme_Object *boxenv; + + boxenv = scheme_alloc_object(); + boxenv->type = scheme_boxenv_type; + SCHEME_PTR1_VAL(boxenv) = pos; + SCHEME_PTR2_VAL(boxenv) = scheme_false; + + if (last) + last->body = boxenv; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = boxenv; + else + SCHEME_PTR2_VAL(last_body) = boxenv; + last = NULL; + last_body = boxenv; + last_seq = NULL; + } else { + /* For regular let, delay the boxing until all RHSs are + evaluated. */ + boxes = scheme_make_pair(pos, boxes); + } + } + } + } + } + } + } + + /* Resolve body: */ + body = scheme_resolve_expr(body, linfo); + + while (SCHEME_PAIRP(boxes)) { + /* See bangboxenv... */ + Scheme_Object *bcode; + bcode = scheme_alloc_object(); + bcode->type = scheme_boxenv_type; + SCHEME_PTR1_VAL(bcode) = SCHEME_CAR(boxes); + SCHEME_PTR2_VAL(bcode) = body; + body = bcode; + boxes = SCHEME_CDR(boxes); + } + + if (letrec) { + letrec->body = body; + if (last) + last->body = (Scheme_Object *)letrec; + else if (last_body) + SCHEME_PTR2_VAL(last_body) = (Scheme_Object *)letrec; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)letrec; + else + first = (Scheme_Object *)letrec; + } else if (last) + last->body = body; + else if (last_body) + SCHEME_PTR2_VAL(last_body) = body; + else if (last_seq) + ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)body; + else + first = body; + + if (head->count + extra_alloc - num_skips) { + int cnt; + + cnt = head->count + extra_alloc - num_skips; + + if (!recbox && (cnt == 1) + && (SAME_TYPE(SCHEME_TYPE(first), scheme_let_value_type)) + && (((Scheme_Let_Value *)first)->count == 1) + && (((Scheme_Let_Value *)first)->position == 0)) { + /* Simplify to let-one after all */ + Scheme_Let_One *lo; + int et; + + lo = MALLOC_ONE_TAGGED(Scheme_Let_One); + lo->iso.so.type = scheme_let_one_type; + lo->value = ((Scheme_Let_Value *)first)->value; + lo->body = ((Scheme_Let_Value *)first)->body; + + et = scheme_get_eval_type(lo->value); + SCHEME_LET_EVAL_TYPE(lo) = et; + + first = (Scheme_Object *)lo; + } else { + Scheme_Let_Void *lvd; + + lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void); + lvd->iso.so.type = scheme_let_void_type; + lvd->body = first; + lvd->count = cnt; + SCHEME_LET_AUTOBOX(lvd) = recbox; + + first = (Scheme_Object *)lvd; + } + } + + if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc) + info->max_let_depth = linfo->max_let_depth + head->count - num_skips + extra_alloc; + merge_resolve_tl_map(info, linfo); + if (val_linfo) { + if (info->max_let_depth < val_linfo->max_let_depth + head->count - num_skips + extra_alloc) + info->max_let_depth = val_linfo->max_let_depth + head->count - num_skips + extra_alloc; + merge_resolve_tl_map(info, val_linfo); + } + + return first; +} + +/*========================================================================*/ +/* closures */ +/*========================================================================*/ + +XFORM_NONGCING static int boxmap_size(int n) +{ + return ((2 * n) + (BITS_PER_MZSHORT - 1)) / BITS_PER_MZSHORT; +} + +static mzshort *allocate_boxmap(int n) +{ + mzshort *boxmap; + int size; + + size = boxmap_size(n); + boxmap = MALLOC_N_ATOMIC(mzshort, size); + memset(boxmap, 0, size * sizeof(mzshort)); + + return boxmap; +} + +XFORM_NONGCING static void boxmap_set(mzshort *boxmap, int j, int bit, int delta) +{ + boxmap[delta + ((2 * j) / BITS_PER_MZSHORT)] |= ((mzshort)bit << ((2 * j) & (BITS_PER_MZSHORT - 1))); +} + +XFORM_NONGCING static int boxmap_get(mzshort *boxmap, int j, int bit) +{ + if (boxmap[(2 * j) / BITS_PER_MZSHORT] & ((mzshort)bit << ((2 * j) & (BITS_PER_MZSHORT - 1)))) + return 1; + else + return 0; +} + +static Scheme_Object * +resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, + int can_lift, int convert, int just_compute_lift, + Scheme_Object *precomputed_lift) +{ + Scheme_Closure_Data *data; + int i, closure_size, offset, np, num_params, expanded_already = 0; + int has_tl, convert_size, need_lift; + mzshort *oldpos, *closure_map, *new_closure_map; + Closure_Info *cl; + Resolve_Info *new_info; + Scheme_Object *lifted, *result, *lifteds = NULL; + Scheme_Hash_Table *captured = NULL; + mzshort *convert_map, *convert_boxes = NULL; + + data = (Scheme_Closure_Data *)_data; + cl = (Closure_Info *)data->closure_map; + if (!just_compute_lift) + data->iso.so.type = scheme_unclosed_procedure_type; + + if (convert || can_lift) { + if (!convert && !resolving_in_procedure(info)) + can_lift = 0; /* no point in lifting when outside of a lambda or letrec */ + if (!info->lifts) + can_lift = 0; + } + + /* We have to perform a small bit of constant propagation here. + Procedures closed only over top-level bindings are lifted during + this pass. Some of the captured bindings from this phase may + refer to a lifted procedure. In that case, we can replace the + lexical reference with a direct reference to the top-level + binding, which means that we can drop the binding from the + closure. */ + + closure_size = data->closure_size; + if (cl->flonum_map) { + int at_least_one = 0; + for (i = data->num_params; i--; ) { + if (cl->flonum_map[i]) { + if (cl->local_flags[i] & SCHEME_WAS_FLONUM_ARGUMENT) + at_least_one = 1; + else + cl->flonum_map[i] = 0; + } + } + if (at_least_one) { + closure_size += boxmap_size(data->num_params + closure_size); + expanded_already = 1; + } else + cl->flonum_map = NULL; + } + closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size); + if (cl->flonum_map) + memset(closure_map, 0, sizeof(mzshort) * closure_size); + + has_tl = cl->has_tl; + if (has_tl && !can_lift) + convert = 0; + + /* Locals in closure are first: */ + oldpos = cl->base_closure_map; + offset = 0; + for (i = 0; i < cl->base_closure_size; i++) { + int li, flags; + li = resolve_info_lookup(info, oldpos[i], &flags, &lifted, 0); + if (lifted) { + /* Drop lifted binding from closure. */ + if (SAME_TYPE(SCHEME_TYPE(lifted), scheme_toplevel_type) + || SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(lifted)), scheme_toplevel_type)) { + has_tl = 1; + if (!can_lift) + convert = 0; + } + /* If the lifted binding is for a converted closure, + we may need to add more bindings to this closure. */ + if (SCHEME_RPAIRP(lifted)) { + lifteds = scheme_make_raw_pair(lifted, lifteds); + } + } else { + closure_map[offset] = li; + if (convert && (flags & (SCHEME_INFO_BOXED | SCHEME_INFO_FLONUM_ARG))) { + /* The only problem with a boxed/flonum variable is that + it's more difficult to validate. We have to track + which arguments are boxes. And the resulting procedure + must be used only in application positions. */ + if (!convert_boxes) + convert_boxes = allocate_boxmap(cl->base_closure_size); + boxmap_set(convert_boxes, offset, (flags & SCHEME_INFO_BOXED) ? 1 : 2, 0); + } else { + /* Currently, we only need flonum information as a closure type */ + if (flags & SCHEME_INFO_FLONUM_ARG) { + if (!expanded_already) { + closure_size += boxmap_size(data->num_params + closure_size); + new_closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * closure_size); + memset(new_closure_map, 0, sizeof(mzshort) * closure_size); + memcpy(new_closure_map, closure_map, sizeof(mzshort) * data->closure_size); + closure_map = new_closure_map; + expanded_already = 1; + } + boxmap_set(closure_map, data->num_params + offset, 2, data->closure_size); + } + } + offset++; + } + } + + /* Add bindings introduced by closure conversion. The `captured' + table maps old positions to new positions. */ + while (lifteds) { + int j, cnt, boxed, flonumed; + Scheme_Object *vec, *loc; + + if (!captured) { + captured = scheme_make_hash_table(SCHEME_hash_ptr); + for (i = 0; i < offset; i++) { + int cp; + cp = i; + if (convert_boxes) { + if (boxmap_get(convert_boxes, i, 1)) + cp = -((2 * cp) + 1); + else if (boxmap_get(convert_boxes, i, 2)) + cp = -((2 * cp) + 2); + } + scheme_hash_set(captured, scheme_make_integer(closure_map[i]), scheme_make_integer(cp)); + } + } + + lifted = SCHEME_CAR(lifteds); + vec = SCHEME_CDR(lifted); + cnt = SCHEME_VEC_SIZE(vec); + --cnt; + for (j = 0; j < cnt; j++) { + loc = SCHEME_VEC_ELS(vec)[j+1]; + if (SCHEME_BOXP(loc)) { + loc = SCHEME_BOX_VAL(loc); + boxed = 1; + flonumed = 0; + } else if (SCHEME_VECTORP(loc)) { + loc = SCHEME_VEC_ELS(loc)[0]; + boxed = 0; + flonumed = 1; + } else { + boxed = 0; + flonumed = 0; + } + i = SCHEME_LOCAL_POS(loc); + if (!scheme_hash_get(captured, scheme_make_integer(i))) { + /* Need to capture an extra binding: */ + int cp; + cp = captured->count; + if (boxed) + cp = -((2 * cp) + 1); + else if (flonumed) + cp = -((2 * cp) + 2); + scheme_hash_set(captured, scheme_make_integer(i), scheme_make_integer(cp)); + } + } + + lifteds = SCHEME_CDR(lifteds); + } + + if (captured && (captured->count > offset)) { + /* We need to extend the closure map. All the info + is in captured, so just build it from scratch. */ + int old_pos, j, new_size; + new_size = (captured->count + (has_tl ? 1 : 0)); + if (cl->flonum_map) + new_size += boxmap_size(data->num_params + new_size); + closure_map = (mzshort *)scheme_malloc_atomic(sizeof(mzshort) * new_size); + if (cl->flonum_map) + memset(closure_map, 0, sizeof(mzshort) * new_size); + offset = captured->count; + convert_boxes = NULL; + for (j = captured->size; j--; ) { + if (captured->vals[j]) { + int cp; + cp = SCHEME_INT_VAL(captured->vals[j]); + old_pos = SCHEME_INT_VAL(captured->keys[j]); + if (cp < 0) { + /* Boxed or flonum */ + int bit; + cp = -cp; + if (cp & 0x1) { + cp = (cp - 1) / 2; + bit = 1; + } else { + cp = (cp - 2) / 2; + bit = 2; + } + if (!convert_boxes) + convert_boxes = allocate_boxmap(offset); + boxmap_set(convert_boxes, cp, bit, 0); + } + closure_map[cp] = old_pos; + } + } + } + + if (convert + && (offset || !has_tl) /* either need args, or treat as convert because it's fully closed */ + ) { + /* Take over closure_map to be the convert map, instead. */ + convert_map = closure_map; + convert_size = offset; + + if (has_tl || convert_boxes || cl->flonum_map) { + int new_boxes_size; + int sz; + new_boxes_size = boxmap_size(convert_size + data->num_params + (has_tl ? 1 : 0)); + sz = ((has_tl ? sizeof(mzshort) : 0) + new_boxes_size * sizeof(mzshort)); + closure_map = (mzshort *)scheme_malloc_atomic(sz); + memset(closure_map, 0, sz); + if (convert_boxes) { + int bsz; + bsz = boxmap_size(convert_size); + memcpy(closure_map XFORM_OK_PLUS (has_tl ? 1 : 0), + convert_boxes, + bsz * sizeof(mzshort)); + } + } else + closure_map = NULL; + offset = 0; + } else { + convert = 0; + convert_map = NULL; + convert_size = 0; + convert_boxes = NULL; + } + + /* Then the pointer to globals, if any: */ + if (has_tl) { + /* GLOBAL ASSUMPTION: jit.c assumes that the array + of globals is the last item in the closure; grep + for "GLOBAL ASSUMPTION" in jit.c and mzmark.c */ + int li; + li = resolve_toplevel_pos(info); + closure_map[offset] = li; + offset++; + } + + /* Reset closure_size, in case a lifted variable was removed: */ + closure_size = offset; + if (!just_compute_lift) { + data->closure_size = closure_size; + if (convert && convert_boxes) + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_TYPED_ARGS; + } + + /* Set up environment mapping, initialized for arguments: */ + + np = num_params = data->num_params; + if ((data->num_params == 1) + && (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) + && !(cl->local_flags[0] & SCHEME_WAS_USED) + && !convert) { + /* (lambda args E) where args is not in E => drop the argument */ + new_info = resolve_info_extend(info, 0, 1, cl->base_closure_size); + num_params = 0; + if (!just_compute_lift) + data->num_params = 0; + } else { + new_info = resolve_info_extend(info, data->num_params, data->num_params, + cl->base_closure_size + data->num_params); + for (i = 0; i < data->num_params; i++) { + resolve_info_add_mapping(new_info, i, i + closure_size + convert_size, + (((cl->local_flags[i] & SCHEME_WAS_SET_BANGED) + ? SCHEME_INFO_BOXED + : 0) + | ((cl->flonum_map && cl->flonum_map[i]) + ? SCHEME_INFO_FLONUM_ARG + : 0)), + NULL); + if (cl->flonum_map && cl->flonum_map[i]) + boxmap_set(closure_map, i + convert_size, 2, closure_size); + } + if (expanded_already && !just_compute_lift) + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_HAS_TYPED_ARGS; + } + + /* Extend mapping to go from old locations on the stack (as if bodies were + evaluated immediately) to new locations (where closures + effectively shift and compact values on the stack). + + We don't have to include bindings added because an oiriginal + binding was lifted (i.e., the extra bindings in `captured'), + because they don't appear in the body. Instead, they are + introduced directly in resolved form through the `lifted' info. + That means, though, that we need to transform the `lifted' + mapping. */ + if (has_tl && convert) { + /* Skip handle for globals */ + offset = 1; + } else { + offset = 0; + } + for (i = 0; i < cl->base_closure_size; i++) { + int p = oldpos[i], flags; + + if (p < 0) + p -= np; + else + p += np; + + flags = resolve_info_flags(info, oldpos[i], &lifted); + + if (lifted && SCHEME_RPAIRP(lifted)) { + /* Convert from a vector of local references to an array of + positions. */ + Scheme_Object *vec, *loc, **ca; + mzshort *cmap, *boxmap = NULL; + int sz, j, cp; + + vec = SCHEME_CDR(lifted); + sz = SCHEME_VEC_SIZE(vec); + --sz; + cmap = MALLOC_N_ATOMIC(mzshort, sz); + for (j = 0; j < sz; j++) { + loc = SCHEME_VEC_ELS(vec)[j+1]; + if (SCHEME_BOXP(loc)) { + if (!boxmap) + boxmap = allocate_boxmap(sz); + boxmap_set(boxmap, j, 1, 0); + loc = SCHEME_BOX_VAL(loc); + } else if (SCHEME_VECTORP(loc)) { + if (!boxmap) + boxmap = allocate_boxmap(sz); + boxmap_set(boxmap, j, 2, 0); + loc = SCHEME_VEC_ELS(loc)[0]; + } + loc = scheme_hash_get(captured, scheme_make_integer(SCHEME_LOCAL_POS(loc))); + cp = SCHEME_INT_VAL(loc); + if (cp < 0) { + cp = -cp; + if (cp & 0x1) + cp = (cp - 1) / 2; + else + cp = (cp - 2) / 2; + } + cmap[j] = cp + (has_tl && convert ? 1 : 0); + } + + ca = MALLOC_N(Scheme_Object *, 4); + ca[0] = scheme_make_integer(sz); + ca[1] = (Scheme_Object *)cmap; + ca[2] = SCHEME_VEC_ELS(vec)[0]; + ca[3] = (Scheme_Object *)boxmap; + + lifted = scheme_make_raw_pair(SCHEME_CAR(lifted), (Scheme_Object *)ca); + } + + resolve_info_add_mapping(new_info, p, lifted ? 0 : offset++, flags, lifted); + } + if (has_tl) { + if (convert) + offset = 0; /* other closure elements converted to arguments */ + else + offset = closure_size - 1; + resolve_info_set_toplevel_pos(new_info, offset); + } + + if (!just_compute_lift) + data->closure_map = closure_map; + + new_info->in_proc = 1; + + if (!just_compute_lift) { + Scheme_Object *code; + code = scheme_resolve_expr(data->code, new_info); + data->code = code; + + data->max_let_depth = (new_info->max_let_depth + + num_params + + closure_size + + convert_size + + SCHEME_TAIL_COPY_THRESHOLD); + + data->tl_map = new_info->tl_map; + + /* Add code to box set!ed argument variables: */ + for (i = 0; i < num_params; i++) { + if (cl->local_flags[i] & SCHEME_WAS_SET_BANGED) { + int j = i + closure_size + convert_size; + Scheme_Object *bcode; + + bcode = scheme_alloc_object(); + bcode->type = scheme_boxenv_type; + SCHEME_PTR1_VAL(bcode) = scheme_make_integer(j); + SCHEME_PTR2_VAL(bcode) = data->code; + + data->code = bcode; + } + } + } + + if ((closure_size == 1) + && can_lift + && has_tl + && info->lifts) { + need_lift = 1; + } else + need_lift = 0; + + if (convert) { + num_params += convert_size; + if (!just_compute_lift) + data->num_params = num_params; + } + + /* If the closure is empty, create the closure now */ + if (!closure_size) { + if (precomputed_lift) { + result = SCHEME_CAR(precomputed_lift); + if (!just_compute_lift) + ((Scheme_Closure *)result)->code = data; + } else { + if (just_compute_lift) + result = (Scheme_Object *)scheme_malloc_empty_closure(); + else + result = scheme_make_closure(NULL, (Scheme_Object *)data, 0); + } + } else + result = (Scheme_Object *)data; + + if (need_lift) { + if (just_compute_lift) { + if (just_compute_lift > 1) + result = resolve_invent_toplevel(info); + else + result = resolve_generate_stub_lift(); + } else { + Scheme_Object *tl, *defn_tl; + if (precomputed_lift) { + tl = precomputed_lift; + if (SCHEME_RPAIRP(tl)) + tl = SCHEME_CAR(tl); + } else { + tl = resolve_invent_toplevel(info); + } + defn_tl = resolve_invented_toplevel_to_defn(info, tl); + resolve_lift_definition(info, defn_tl, result); + if (has_tl) + closure_map[0] = 0; /* globals for closure creation will be at 0 after lifting */ + result = tl; + } + } else { + merge_resolve_tl_map(info, new_info); + } + + if (convert) { + Scheme_Object **ca, *arity; + + if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST)) { + arity = scheme_box(scheme_make_integer(num_params - convert_size - 1)); + } else { + arity = scheme_make_integer(num_params - convert_size); + } + + ca = MALLOC_N(Scheme_Object *, 4); + ca[0] = scheme_make_integer(convert_size); + ca[1] = (Scheme_Object *)convert_map; + ca[2] = arity; + ca[3] = (Scheme_Object *)convert_boxes; + + if (precomputed_lift) { + SCHEME_CAR(precomputed_lift) = result; + SCHEME_CDR(precomputed_lift) = (Scheme_Object *)ca; + result = precomputed_lift; + } else + result = scheme_make_raw_pair(result, (Scheme_Object *)ca); + } + + return result; +} + +/*========================================================================*/ +/* module */ +/*========================================================================*/ + +static Scheme_Object * +module_expr_resolve(Scheme_Object *data, Resolve_Info *old_rslv) +{ + Scheme_Module *m = (Scheme_Module *)data; + Scheme_Object *b, *lift_vec; + Resolve_Prefix *rp; + Resolve_Info *rslv; + int i, cnt; + + rp = scheme_resolve_prefix(0, m->comp_prefix, 1); + m->comp_prefix = NULL; + + b = scheme_resolve_expr(m->dummy, old_rslv); + m->dummy = b; + + rslv = scheme_resolve_info_create(rp); + rslv->enforce_const = old_rslv->enforce_const; + rslv->in_module = 1; + scheme_enable_expression_resolve_lifts(rslv); + + cnt = SCHEME_VEC_SIZE(m->body); + for (i = 0; i < cnt; i++) { + Scheme_Object *e; + e = scheme_resolve_expr(SCHEME_VEC_ELS(m->body)[i], rslv); + SCHEME_VEC_ELS(m->body)[i] = e; + } + + m->max_let_depth = rslv->max_let_depth; + + lift_vec = rslv->lifts; + if (!SCHEME_NULLP(SCHEME_VEC_ELS(lift_vec)[0])) { + b = scheme_append(SCHEME_VEC_ELS(lift_vec)[0], scheme_vector_to_list(m->body)); + b = scheme_list_to_vector(b); + m->body = b; + } + rp->num_lifts = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); + + rp = scheme_remap_prefix(rp, rslv); + + m->prefix = rp; + + /* Exp-time body was resolved during compilation */ + + return data; +} + +static Scheme_Object * +top_level_require_resolve(Scheme_Object *data, Resolve_Info *rslv) +{ + Scheme_Object *dummy = SCHEME_PTR1_VAL(data); + + dummy = scheme_resolve_expr(dummy, rslv); + + SCHEME_PTR1_VAL(data) = dummy; + + return data; +} + +/*========================================================================*/ +/* expressions */ +/*========================================================================*/ + +static Scheme_Object *resolve_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *expr = (Scheme_Object *)p->ku.k.p1; + Resolve_Info *info = (Resolve_Info *)p->ku.k.p2; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + return scheme_resolve_expr(expr, info); +} + +Scheme_Object *scheme_resolve_expr(Scheme_Object *expr, Resolve_Info *info) +{ + Scheme_Type type = SCHEME_TYPE(expr); + +#ifdef DO_STACK_CHECK +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + + p->ku.k.p1 = (void *)expr; + p->ku.k.p2 = (void *)info; + + return scheme_handle_stack_overflow(resolve_k); + } +#endif + + switch (type) { + case scheme_local_type: + { + int pos, flags; + Scheme_Object *lifted; + + pos = resolve_info_lookup(info, SCHEME_LOCAL_POS(expr), &flags, &lifted, 0); + if (lifted) { + /* Lexical reference replaced with top-level reference for a lifted value: */ + return lifted; + } else { + return scheme_make_local((flags & SCHEME_INFO_BOXED) + ? scheme_local_unbox_type + : scheme_local_type, + pos, + ((flags & SCHEME_INFO_FLONUM_ARG) + ? SCHEME_LOCAL_FLONUM + : 0)); + } + } + case scheme_application_type: + return resolve_application(expr, info, 0); + case scheme_application2_type: + return resolve_application2(expr, info, 0); + case scheme_application3_type: + return resolve_application3(expr, info, 0); + case scheme_sequence_type: + case scheme_begin0_sequence_type: + case scheme_splice_sequence_type: + return resolve_sequence(expr, info); + case scheme_branch_type: + return resolve_branch(expr, info); + case scheme_with_cont_mark_type: + return resolve_wcm(expr, info); + case scheme_compiled_unclosed_procedure_type: + return resolve_closure_compilation(expr, info, 1, 0, 0, NULL); + case scheme_compiled_let_void_type: + return scheme_resolve_lets(expr, info); + case scheme_compiled_toplevel_type: + return resolve_toplevel(info, expr, 1); + case scheme_compiled_quote_syntax_type: + { + Scheme_Quote_Syntax *qs; + int i, c, p; + + i = SCHEME_LOCAL_POS(expr); + i = resolve_quote_syntax_offset(i, info); + c = resolve_toplevel_pos(info); + p = resolve_quote_syntax_pos(info); + + qs = MALLOC_ONE_TAGGED(Scheme_Quote_Syntax); + qs->so.type = scheme_quote_syntax_type; + qs->depth = c; + qs->position = i; + qs->midpoint = p; + + return (Scheme_Object *)qs; + } + case scheme_variable_type: + case scheme_module_variable_type: + scheme_signal_error("got top-level in wrong place"); + return 0; + case scheme_define_values_type: + return define_values_resolve(expr, info); + case scheme_define_syntaxes_type: + return define_syntaxes_resolve(expr, info); + case scheme_define_for_syntax_type: + return define_for_syntaxes_resolve(expr, info); + case scheme_set_bang_type: + return set_resolve(expr, info); + case scheme_require_form_type: + return top_level_require_resolve(expr, info); + case scheme_varref_form_type: + return ref_resolve(expr, info); + case scheme_apply_values_type: + return apply_values_resolve(expr, info); + case scheme_case_lambda_sequence_type: + return case_lambda_resolve(expr, info); + case scheme_module_type: + return module_expr_resolve(expr, info); + case scheme_boxenv_type: + scheme_signal_error("internal error: no boxenv resolve"); + default: + return expr; + } +} + +Scheme_Object *scheme_resolve_list(Scheme_Object *expr, Resolve_Info *info) +{ + Scheme_Object *first = scheme_null, *last = NULL; + + while (SCHEME_PAIRP(expr)) { + Scheme_Object *pr; + + pr = scheme_make_pair(scheme_resolve_expr(SCHEME_CAR(expr), info), + scheme_null); + + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + + expr = SCHEME_CDR(expr); + } + + return first; +} + +/*========================================================================*/ +/* compile-time env for resolve */ +/*========================================================================*/ + +Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify) +{ + Resolve_Prefix *rp; + Scheme_Object **tls, **stxes, *simplify_cache, *m; + Scheme_Hash_Table *ht; + int i; + + rp = MALLOC_ONE_TAGGED(Resolve_Prefix); + rp->so.type = scheme_resolve_prefix_type; + rp->num_toplevels = cp->num_toplevels; + rp->num_stxes = cp->num_stxes; + rp->uses_unsafe = cp->uses_unsafe; + + if (rp->num_toplevels) + tls = MALLOC_N(Scheme_Object*, rp->num_toplevels); + else + tls = NULL; + if (rp->num_stxes) + stxes = MALLOC_N(Scheme_Object*, rp->num_stxes); + else + stxes = NULL; + + rp->toplevels = tls; + rp->stxes = stxes; + + ht = cp->toplevels; + if (ht) { + for (i = 0; i < ht->size; i++) { + if (ht->vals[i]) { + m = ht->keys[i]; + if (SAME_TYPE(SCHEME_TYPE(m), scheme_module_variable_type)) { + if (SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->base) + && SCHEME_FALSEP(((Scheme_Modidx *)((Module_Variable *)m)->modidx)->path)) { + /* Reduce self-referece to just a symbol: */ + m = ((Module_Variable *)m)->sym; + } + } + tls[SCHEME_TOPLEVEL_POS(ht->vals[i])] = m; + } + } + } + + if (simplify) + simplify_cache = scheme_new_stx_simplify_cache(); + else + simplify_cache = NULL; + + ht = cp->stxes; + if (ht) { + for (i = 0; i < ht->size; i++) { + if (ht->vals[i]) { + scheme_simplify_stx(ht->keys[i], simplify_cache); + stxes[SCHEME_LOCAL_POS(ht->vals[i])] = ht->keys[i]; + } + } + } + + return rp; +} + +Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri) +{ + /* Rewrite stxes list based on actual uses at resolve pass. + If we have no lifts, we can just drop unused stxes. + Otherwise, if any stxes go unused, we just have to replace them + with NULL. */ + int i, cnt; + Scheme_Object **new_stxes, *v; + + if (!rp->num_stxes) + return rp; + + if (rp->num_lifts) + cnt = rp->num_stxes; + else + cnt = (int)ri->stx_map->count; + + new_stxes = MALLOC_N(Scheme_Object *, cnt); + + for (i = 0; i < rp->num_stxes; i++) { + if (ri->stx_map) + v = scheme_hash_get(ri->stx_map, scheme_make_integer(i)); + else + v = NULL; + if (v) { + new_stxes[SCHEME_INT_VAL(v)] = rp->stxes[i]; + } + } + + rp->stxes = new_stxes; + rp->num_stxes = cnt; + + return rp; +} + +Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp) +{ + Resolve_Info *naya; + Scheme_Object *b; + Scheme_Hash_Table *ht; + + naya = MALLOC_ONE_RT(Resolve_Info); +#ifdef MZTAG_REQUIRED + naya->type = scheme_rt_resolve_info; +#endif + naya->prefix = rp; + naya->count = 0; + naya->next = NULL; + naya->toplevel_pos = -1; + + ht = scheme_make_hash_table(SCHEME_hash_ptr); + naya->stx_map = ht; + + b = scheme_get_param(scheme_current_config(), MZCONFIG_USE_JIT); + naya->use_jit = SCHEME_TRUEP(b); + + return naya; +} + +void scheme_enable_expression_resolve_lifts(Resolve_Info *ri) +{ + Scheme_Object *lift_vec; + + lift_vec = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(lift_vec)[0] = scheme_null; + SCHEME_VEC_ELS(lift_vec)[1] = scheme_make_integer(0); + ri->lifts = lift_vec; +} + +Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri) +{ + Scheme_Object *lift_vec, *lifts; + Scheme_Sequence *s; + int n, i; + + lift_vec = ri->lifts; + n = SCHEME_INT_VAL(SCHEME_VEC_ELS(lift_vec)[1]); + if (n) { + rp->num_lifts = n; + lifts = SCHEME_VEC_ELS(lift_vec)[0]; + + s = scheme_malloc_sequence(n + 1); + s->so.type = scheme_sequence_type; + s->count = n + 1; + for (i = 0; i < n; i++, lifts = SCHEME_CDR(lifts)) { + s->array[i] = SCHEME_CAR(lifts); + } + s->array[i] = expr; + + return (Scheme_Object *)s; + } else + return expr; +} + +void scheme_resolve_info_enforce_const(Resolve_Info *ri, int enforce_const) +{ + ri->enforce_const = enforce_const; +} + +int scheme_resolve_info_use_jit(Resolve_Info *ri) +{ + return ri->use_jit; +} + +int scheme_resolve_info_max_let_depth(Resolve_Info *ri) +{ + return ri->max_let_depth; +} + +static Resolve_Info *resolve_info_extend(Resolve_Info *info, int size, int oldsize, int mapc) + /* size = number of appended items in run-time frame */ + /* oldisze = number of appended items in original compile-time frame */ + /* mapc = mappings that will be installed */ +{ + Resolve_Info *naya; + + naya = MALLOC_ONE_RT(Resolve_Info); +#ifdef MZTAG_REQUIRED + naya->type = scheme_rt_resolve_info; +#endif + naya->prefix = info->prefix; + naya->stx_map = info->stx_map; + naya->next = info; + naya->use_jit = info->use_jit; + naya->enforce_const = info->enforce_const; + naya->size = size; + naya->oldsize = oldsize; + naya->count = mapc; + naya->pos = 0; + naya->toplevel_pos = -1; + naya->lifts = info->lifts; + + if (mapc) { + int i, *ia; + mzshort *sa; + + sa = MALLOC_N_ATOMIC(mzshort, mapc); + naya->old_pos = sa; + sa = MALLOC_N_ATOMIC(mzshort, mapc); + naya->new_pos = sa; + ia = MALLOC_N_ATOMIC(int, mapc); + naya->flags = ia; + + for (i = mapc; i--; ) { + naya->old_pos[i] = 0; + naya->new_pos[i] = 0; + naya->flags[i] = 0; + } + } + + return naya; +} + +static void *ensure_tl_map_len(void *old_tl_map, int new_len) +{ + int current_len; + void *tl_map; + + if (!old_tl_map) + current_len = 0; + else if ((uintptr_t)old_tl_map & 0x1) + current_len = 31; + else + current_len = (*(int *)old_tl_map) * 32; + + if (new_len > current_len) { + /* allocate/grow tl_map */ + if (new_len <= 31) + tl_map = (void *)0x1; + else { + int len = ((new_len + 31) / 32); + tl_map = scheme_malloc_atomic((len + 1) * sizeof(int)); + memset(tl_map, 0, (len + 1) * sizeof(int)); + *(int *)tl_map = len; + } + + if (old_tl_map) { + if ((uintptr_t)old_tl_map & 0x1) { + ((int *)tl_map)[1] = ((uintptr_t)old_tl_map >> 1) & 0x7FFFFFFF; + } else { + memcpy((int *)tl_map + 1, + (int *)old_tl_map + 1, + sizeof(int) * (current_len / 32)); + } + } + + return tl_map; + } else + return old_tl_map; +} + +static void set_tl_pos_used(Resolve_Info *info, int pos) +{ + int tl_pos; + void *tl_map; + + /* Fixnum-like bit packing avoids allocation in the common case of a + small prefix. We use 31 fixnum-like bits (even on a 64-bit + platform, and even though fixnums are only 30 bits). */ + + if (pos >= info->prefix->num_toplevels) + tl_pos = pos - (info->prefix->num_stxes + ? (info->prefix->num_stxes + 1) + : 0); + else + tl_pos = pos; + + tl_map = ensure_tl_map_len(info->tl_map, tl_pos + 1); + info->tl_map = tl_map; + + if ((uintptr_t)info->tl_map & 0x1) + info->tl_map = (void *)((uintptr_t)tl_map | ((uintptr_t)1 << (tl_pos + 1))); + else + ((int *)tl_map)[1 + (tl_pos / 32)] |= (1 << (tl_pos & 31)); +} + +static void *merge_tl_map(void *tl_map, void *new_tl_map) +{ + if (!tl_map) + return new_tl_map; + else if (!new_tl_map) + return tl_map; + else if (((uintptr_t)new_tl_map) & 0x1) { + if (((uintptr_t)tl_map) & 0x1) { + return (void *)((uintptr_t)tl_map | (uintptr_t)new_tl_map); + } else { + ((int *)tl_map)[1] |= ((uintptr_t)new_tl_map >> 1) & 0x7FFFFFFF; + return tl_map; + } + } else { + int i, len = *(int *)new_tl_map; + tl_map = ensure_tl_map_len(tl_map, len * 32); + for (i = 0; i < len; i++) { + ((int *)tl_map)[1+i] |= ((int *)new_tl_map)[1+i]; + } + return tl_map; + } +} + +static void merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info) +{ + if (!new_info->tl_map) { + /* nothing to do */ + } else { + void *tl_map; + tl_map = merge_tl_map(info->tl_map, new_info->tl_map); + info->tl_map = tl_map; + } +} + +static void resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted) +{ + if (info->pos == info->count) { + scheme_signal_error("internal error: add_mapping: " + "too many: %d", info->pos); + } + + info->old_pos[info->pos] = oldp; + info->new_pos[info->pos] = newp; + info->flags[info->pos] = flags; + if (lifted) { + if (!info->lifted) { + Scheme_Object **lifteds; + lifteds = MALLOC_N(Scheme_Object*, info->count); + info->lifted = lifteds; + } + info->lifted[info->pos] = lifted; + } + + info->pos++; +} + +static void resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted) +{ + int i; + + for (i = info->pos; i--; ) { + if (info->old_pos[i] == oldp) { + info->new_pos[i] = newp; + info->flags[i] = flags; + if (lifted) { + info->lifted[i] = lifted; + } + return; + } + } + + scheme_signal_error("internal error: adjust_mapping: " + "couldn't find: %d", oldp); +} + +static void resolve_info_set_toplevel_pos(Resolve_Info *info, int pos) +{ + info->toplevel_pos = pos; +} + +static int do_resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **_lifted, int convert_shift) +{ + Resolve_Info *orig_info = info; + int i, offset = 0, orig = pos; + + if (_lifted) + *_lifted = NULL; + + while (info) { + for (i = info->pos; i--; ) { + int oldp = info->old_pos[i]; + if (pos == oldp) { + if (flags) + *flags = info->flags[i]; + if (info->lifted && (info->lifted[i])) { + int skip, shifted; + Scheme_Object *lifted, *tl, **ca; + + if (!_lifted) + scheme_signal_error("unexpected lifted binding"); + + lifted = info->lifted[i]; + + if (SCHEME_RPAIRP(lifted)) { + tl = SCHEME_CAR(lifted); + ca = (Scheme_Object **)SCHEME_CDR(lifted); + if (convert_shift) + shifted = (int)SCHEME_INT_VAL(ca[0]) + convert_shift - 1; + else + shifted = 0; + } else { + tl = lifted; + shifted = 0; + ca = NULL; + } + + if (SAME_TYPE(SCHEME_TYPE(tl), scheme_toplevel_type)) { + skip = resolve_toplevel_pos(orig_info); + tl = scheme_make_toplevel(skip + shifted, + SCHEME_TOPLEVEL_POS(tl), + 1, + SCHEME_TOPLEVEL_CONST); + + /* register if non-stub: */ + if (SCHEME_TOPLEVEL_POS(tl) >= (info->prefix->num_toplevels + + info->prefix->num_stxes + + (info->prefix->num_stxes + ? 1 + : 0))) + set_tl_pos_used(orig_info, SCHEME_TOPLEVEL_POS(tl)); + } + + if (SCHEME_RPAIRP(lifted)) { + int sz, i; + mzshort *posmap, *boxmap; + Scheme_Object *vec, *loc; + sz = (int)SCHEME_INT_VAL(ca[0]); + posmap = (mzshort *)ca[1]; + boxmap = (mzshort *)ca[3]; + vec = scheme_make_vector(sz + 1, NULL); + for (i = 0; i < sz; i++) { + int boxed = 0, flonumed = 0, flags = 0; + + if (boxmap) { + int byte = boxmap[(2 * i) / BITS_PER_MZSHORT]; + if (byte & ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) + boxed = 1; + if (byte & ((mzshort)2 << ((2 * i) & (BITS_PER_MZSHORT - 1)))) { + flonumed = 1; + flags = SCHEME_LOCAL_FLONUM; + } + } + + loc = scheme_make_local(scheme_local_type, + posmap[i] + offset + shifted, + flags); + + if (boxed) + loc = scheme_box(loc); + else if (flonumed) + loc = scheme_make_vector(1, loc); + + SCHEME_VEC_ELS(vec)[i+1] = loc; + } + SCHEME_VEC_ELS(vec)[0] = ca[2]; + lifted = scheme_make_raw_pair(tl, vec); + } else + lifted = tl; + + *_lifted = lifted; + + return 0; + } else { + pos = info->new_pos[i]; + if (pos < 0) + scheme_signal_error("internal error: skipped binding is used"); + return pos + offset; + } + } + } + + if (info->in_proc) { + scheme_signal_error("internal error: resolve_info_lookup: " + "searching past procedure"); + } + + pos -= info->oldsize; + offset += info->size; + info = info->next; + } + + scheme_signal_error("internal error: resolve_info_lookup: " + "variable %d not found", orig); + + return 0; +} + +static Scheme_Object *resolve_generate_stub_lift() +{ + return scheme_make_toplevel(0, 0, 1, SCHEME_TOPLEVEL_CONST); +} + +static int resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted) +{ + int flags; + + do_resolve_info_lookup(info, pos, &flags, lifted, 0); + + return flags; +} + +static int resolve_info_lookup(Resolve_Info *info, int pos, int *flags, Scheme_Object **lifted, int convert_shift) +{ + return do_resolve_info_lookup(info, pos, flags, lifted, convert_shift); +} + +static int resolve_toplevel_pos(Resolve_Info *info) +{ + int pos = 0; + + while (info && (info->toplevel_pos < 0)) { + if (info->in_proc) { + scheme_signal_error("internal error: resolve_toplevel_pos: " + "searching past procedure"); + } + pos += info->size; + info = info->next; + } + + if (!info) + return pos; + else + return info->toplevel_pos + pos; +} + +static int resolve_is_toplevel_available(Resolve_Info *info) +{ + while (info) { + if (info->toplevel_pos >= 0) + return 1; + if (info->in_proc) + return 0; + info = info->next; + } + + return 0; +} + +static int resolve_quote_syntax_offset(int i, Resolve_Info *info) +{ + Scheme_Hash_Table *ht; + Scheme_Object *v; + + ht = info->stx_map; + + v = scheme_hash_get(ht, scheme_make_integer(i)); + if (!v) { + v = scheme_make_integer(ht->count); + scheme_hash_set(ht, scheme_make_integer(i), v); + } + + return (int)SCHEME_INT_VAL(v); +} + +static int resolve_quote_syntax_pos(Resolve_Info *info) +{ + return info->prefix->num_toplevels; +} + +static Scheme_Object *resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready) +{ + int skip, pos; + + skip = resolve_toplevel_pos(info); + + pos = SCHEME_TOPLEVEL_POS(expr); + + set_tl_pos_used(info, pos); + + return scheme_make_toplevel(skip + SCHEME_TOPLEVEL_DEPTH(expr), /* depth is 0 (normal) or 1 (exp-time) */ + pos, + 1, + SCHEME_TOPLEVEL_FLAGS(expr) & (SCHEME_TOPLEVEL_CONST + | (keep_ready + ? SCHEME_TOPLEVEL_READY + : 0))); +} + +static Scheme_Object *shift_toplevel(Scheme_Object *expr, int delta) +{ + return scheme_make_toplevel(SCHEME_TOPLEVEL_DEPTH(expr) + delta, + SCHEME_TOPLEVEL_POS(expr), + 1, + SCHEME_TOPLEVEL_FLAGS(expr) & SCHEME_TOPLEVEL_FLAGS_MASK); +} + +static Scheme_Object *resolve_invent_toplevel(Resolve_Info *info) +{ + int skip, pos; + Scheme_Object *count; + + skip = resolve_toplevel_pos(info); + + count = SCHEME_VEC_ELS(info->lifts)[1]; + pos = (int)(SCHEME_INT_VAL(count) + + info->prefix->num_toplevels + + info->prefix->num_stxes + + (info->prefix->num_stxes ? 1 : 0)); + count = scheme_make_integer(SCHEME_INT_VAL(count) + 1); + SCHEME_VEC_ELS(info->lifts)[1] = count; + + set_tl_pos_used(info, pos); + + return scheme_make_toplevel(skip, + pos, + 1, + SCHEME_TOPLEVEL_CONST); +} + +static Scheme_Object *resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl) +{ + return scheme_make_toplevel(0, + SCHEME_TOPLEVEL_POS(tl), + 1, + SCHEME_TOPLEVEL_CONST); +} + +static int resolving_in_procedure(Resolve_Info *info) +{ + while (info) { + if (info->in_proc) + return 1; + info = info->next; + } + return 0; +} + +/*========================================================================*/ +/* precise GC traversers */ +/*========================================================================*/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#define MARKS_FOR_RESOLVE_C +#include "mzmark.c" + +static void register_traversers(void) +{ + GC_REG_TRAV(scheme_rt_resolve_info, mark_resolve_info); +} + +END_XFORM_SKIP; + +#endif diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index c7de50da11..e305b1235c 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -190,6 +190,11 @@ void scheme_init_symbol_type(Scheme_Env *env); void scheme_init_type(); void scheme_init_custodian_extractors(); void scheme_init_bignum(); +void scheme_init_compenv(); +void scheme_init_optimize(); +void scheme_init_resolve(); +void scheme_init_sfs(); +void scheme_init_validate(); void scheme_init_list(Scheme_Env *env); void scheme_init_unsafe_list(Scheme_Env *env); void scheme_init_stx(Scheme_Env *env); @@ -222,6 +227,7 @@ void scheme_init_symbol(Scheme_Env *env); void scheme_init_char(Scheme_Env *env); void scheme_init_bool(Scheme_Env *env); void scheme_init_syntax(Scheme_Env *env); +void scheme_init_marshal(Scheme_Env *env); void scheme_init_error(Scheme_Env *env); #ifndef NO_SCHEME_EXNS void scheme_init_exn(Scheme_Env *env); @@ -504,6 +510,12 @@ void scheme_zero_unneeded_rands(Scheme_Thread *p); int scheme_can_break(Scheme_Thread *p); +# define DO_CHECK_FOR_BREAK(p, e) \ + if (DECREMENT_FUEL(scheme_fuel_counter, 1) <= 0) { \ + e scheme_thread_block(0); \ + (p)->ran_some = 1; \ + } + THREAD_LOCAL_DECL(extern int scheme_overflow_count); #define MZTHREADELEM(p, x) scheme_ ## x @@ -1062,6 +1074,16 @@ typedef struct { /* After array of f & args, array of chars for eval type */ } Scheme_App_Rec; +/* Lookahead types for evaluating application arguments. */ +/* 4 cases + else => magic number for some compilers doing a switch? */ +enum { + SCHEME_EVAL_CONSTANT = 0, + SCHEME_EVAL_GLOBAL, + SCHEME_EVAL_LOCAL, + SCHEME_EVAL_LOCAL_UNBOX, + SCHEME_EVAL_GENERAL +}; + typedef struct { Scheme_Inclhash_Object iso; /* keyex used for flags */ Scheme_Object *rator; @@ -2158,25 +2180,21 @@ typedef struct Resolve_Prefix Scheme_Object *uses_unsafe; /* non-NULL => inspector or hashtree of inspectors for accessing #%unsafe bindings */ } Resolve_Prefix; -typedef struct Resolve_Info -{ +typedef struct Resolve_Info Resolve_Info; + +/* Closure_Info is used to store extra closure information + before a closure mapping is resolved. */ +typedef struct { MZTAG_IF_REQUIRED - char use_jit, in_module, in_proc, enforce_const; - int size, oldsize, count, pos; - int max_let_depth; /* filled in by sub-expressions */ - Resolve_Prefix *prefix; - Scheme_Hash_Table *stx_map; /* compile offset => resolve offset; prunes prefix-recored stxes */ - mzshort toplevel_pos; /* -1 means consult `next' */ - void *tl_map; /* fixnum or bit array (as array of `int's) indicating which globals+lifts in prefix are used */ - mzshort *old_pos; - mzshort *new_pos; - int stx_count; - mzshort *old_stx_pos; /* NULL => consult next; new pos is index in array */ - int *flags; - Scheme_Object **lifted; /* maps bindings to lifts */ - Scheme_Object *lifts; /* accumulates lift info */ - struct Resolve_Info *next; -} Resolve_Info; + int *local_flags; /* for arguments from compile pass, flonum info updated in optimize pass */ + mzshort base_closure_size; /* doesn't include top-level (if any) */ + mzshort *base_closure_map; + char *flonum_map; /* NULL when has_flomap set => no flonums */ + char has_tl, has_flomap, has_nonleaf; + int body_size, body_psize; +} Closure_Info; + +typedef struct Optimize_Info Optimize_Info; typedef struct Scheme_Object * (Scheme_Syntax)(struct Scheme_Object *form, struct Scheme_Comp_Env *env, @@ -2186,41 +2204,6 @@ typedef struct Scheme_Object * (Scheme_Syntax_Expander)(struct Scheme_Object *form, struct Scheme_Comp_Env *env, Scheme_Expand_Info *rec, int drec); -typedef struct Scheme_Object *(*Scheme_Syntax_Resolver)(Scheme_Object *data, Resolve_Info *info); - -typedef struct Optimize_Info -{ - MZTAG_IF_REQUIRED - short flags; - struct Optimize_Info *next; - int original_frame, new_frame; - Scheme_Object *consts; - - /* Propagated up and down the chain: */ - int size, vclock, psize; - short inline_fuel; - char letrec_not_twice, enforce_const, use_psize, has_nonleaf; - Scheme_Hash_Table *top_level_consts; - - /* Set by expression optimization: */ - int single_result, preserves_marks; /* negative means "tentative", due to fixpoint in progress */ - - char **stat_dists; /* (pos, depth) => used? */ - int *sd_depths; - int used_toplevel; - char *use; - - int transitive_use_pos; /* set to pos + 1 when optimizing a letrec-bound procedure */ - mzshort **transitive_use; - int *transitive_use_len; - - Scheme_Object *context; /* for logging */ -} Optimize_Info; - -typedef struct Scheme_Object *(*Scheme_Syntax_Optimizer)(Scheme_Object *data, Optimize_Info *info, int context); -typedef struct Scheme_Object *(*Scheme_Syntax_Cloner)(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); -typedef struct Scheme_Object *(*Scheme_Syntax_Shifter)(Scheme_Object *data, int delta, int after_depth); - typedef struct CPort Mz_CPort; typedef mzshort **Validate_TLS; @@ -2366,9 +2349,38 @@ int scheme_push_marks_from_lightweight_continuation(Scheme_Lightweight_Continuat #define scheme_get_frame_settable(f) ((f)->basic.has_set_bang) #define scheme_get_binding(f, n) ((f)->values[n]) +int scheme_is_module_begin_env(Scheme_Comp_Env *env); +Scheme_Object *scheme_make_toplevel(mzshort depth, int position, int resolved, int flags); + +#define MAX_CONST_LOCAL_POS 64 +#define MAX_CONST_LOCAL_TYPES 2 +#define MAX_CONST_LOCAL_FLAG_VAL 3 +#define SCHEME_LOCAL_FLAGS_MASK 0x3 + +#define MAX_CONST_TOPLEVEL_DEPTH 16 +#define MAX_CONST_TOPLEVEL_POS 16 +#define SCHEME_TOPLEVEL_FLAGS_MASK 0x3 + +#define ASSERT_IS_VARIABLE_BUCKET(b) /* if (((Scheme_Object *)b)->type != scheme_variable_type) abort() */ + Scheme_Comp_Env *scheme_new_comp_env(Scheme_Env *genv, Scheme_Object *insp, int flags); Scheme_Comp_Env *scheme_new_expand_env(Scheme_Env *genv, Scheme_Object *insp, int flags); +Scheme_Object *scheme_namespace_lookup_value(Scheme_Object *sym, Scheme_Env *genv, + Scheme_Object **_id, int *_use_map); +Scheme_Object *scheme_find_local_shadower(Scheme_Object *sym, Scheme_Object *sym_marks, + Scheme_Comp_Env *env); +Scheme_Object *scheme_do_local_lift_expr(const char *who, int stx_pos, + int argc, Scheme_Object *argv[]); +Scheme_Object *scheme_local_lift_context(Scheme_Comp_Env *env); +Scheme_Object *scheme_local_lift_end_statement(Scheme_Object *expr, Scheme_Object *local_mark, + Scheme_Comp_Env *env); +Scheme_Object *scheme_local_lift_require(Scheme_Object *form, Scheme_Object *orig_form, + intptr_t phase, Scheme_Object *local_mark, + Scheme_Comp_Env *env); +Scheme_Object *scheme_local_lift_provide(Scheme_Object *form, Scheme_Object *local_mark, + Scheme_Comp_Env *env); + void scheme_check_identifier(const char *formname, Scheme_Object *id, const char *where, Scheme_Comp_Env *env, @@ -2436,6 +2448,8 @@ void scheme_add_local_syntax(int cnt, Scheme_Comp_Env *env); void scheme_set_local_syntax(int pos, Scheme_Object *name, Scheme_Object *val, Scheme_Comp_Env *env); +Scheme_Object *scheme_clone_vector(Scheme_Object *data, int skip, int set_type); + Scheme_Object *scheme_make_closure(Scheme_Thread *p, Scheme_Object *compiled_code, int close); @@ -2445,6 +2459,7 @@ Scheme_Object *scheme_make_native_closure(Scheme_Native_Closure_Data *code); Scheme_Object *scheme_make_native_case_closure(Scheme_Native_Closure_Data *code); void scheme_reset_app2_eval_type(Scheme_App2_Rec *app); +void scheme_reset_app3_eval_type(Scheme_App3_Rec *app); Scheme_Native_Closure_Data *scheme_generate_case_lambda(Scheme_Case_Lambda *cl); @@ -2485,7 +2500,6 @@ typedef struct SFS_Info { SFS_Info *scheme_new_sfs_info(int depth); Scheme_Object *scheme_sfs(Scheme_Object *expr, SFS_Info *info, int max_let_depth); Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *si, int self_pos); -Scheme_Object *scheme_sfs_closure(Scheme_Object *expr, SFS_Info *si, int self_pos); void scheme_sfs_used(SFS_Info *info, int pos); void scheme_sfs_push(SFS_Info *info, int count, int track); @@ -2501,21 +2515,6 @@ typedef struct Scheme_Set_Bang { Scheme_Object *var, *val; } Scheme_Set_Bang; -/* Resolving & linking */ -#define DEFINE_VALUES_EXPD 0 -#define DEFINE_SYNTAX_EXPD 1 -#define SET_EXPD 2 -#define CASE_LAMBDA_EXPD 3 -#define BEGIN0_EXPD 4 -#define BOXENV_EXPD 5 -#define MODULE_EXPD 6 -#define REQUIRE_EXPD 7 -#define DEFINE_FOR_SYNTAX_EXPD 8 -#define REF_EXPD 9 -#define APPVALS_EXPD 10 -#define SPLICE_EXPD 11 -#define _COUNT_EXPD_ 12 - Scheme_Object *scheme_protect_quote(Scheme_Object *expr); #define IS_COMPILED_PROC(vals_expr) (SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_compiled_unclosed_procedure_type) \ @@ -2553,25 +2552,17 @@ Resolve_Prefix *scheme_resolve_prefix(int phase, Comp_Prefix *cp, int simplify); Resolve_Prefix *scheme_remap_prefix(Resolve_Prefix *rp, Resolve_Info *ri); Resolve_Info *scheme_resolve_info_create(Resolve_Prefix *rp); -Resolve_Info *scheme_resolve_info_extend(Resolve_Info *info, int size, int oldsize, int mapcount); -void scheme_resolve_info_add_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted); -void scheme_resolve_info_adjust_mapping(Resolve_Info *info, int oldp, int newp, int flags, Scheme_Object *lifted); -int scheme_resolve_info_flags(Resolve_Info *info, int pos, Scheme_Object **lifted); -int scheme_resolve_info_lookup(Resolve_Info *resolve, int pos, int *flags, Scheme_Object **lifted, int convert_shift); -int scheme_optimize_info_is_ready(Optimize_Info *info, int pos); -void scheme_resolve_info_set_toplevel_pos(Resolve_Info *info, int pos); -void scheme_merge_resolve_tl_map(Resolve_Info *info, Resolve_Info *new_info); -void *scheme_merge_tl_map(void *tl_map, void *new_tl_map); +void scheme_resolve_info_enforce_const(Resolve_Info *, int enforce_const); +int scheme_resolve_info_max_let_depth(Resolve_Info *ri); +int scheme_resolve_info_use_jit(Resolve_Info *ri); void scheme_enable_expression_resolve_lifts(Resolve_Info *ri); Scheme_Object *scheme_merge_expression_resolve_lifts(Scheme_Object *expr, Resolve_Prefix *rp, Resolve_Info *ri); Optimize_Info *scheme_optimize_info_create(void); - -void scheme_optimize_propagate(Optimize_Info *info, int pos, Scheme_Object *value, int single_use); -Scheme_Object *scheme_optimize_info_lookup(Optimize_Info *info, int pos, int *closure_offset, int *single_use, - int once_used_ok, int context, int *potential_size); -void scheme_optimize_info_used_top(Optimize_Info *info); +void scheme_optimize_info_enforce_const(Optimize_Info *, int enforce_const); +void scheme_optimize_info_set_context(Optimize_Info *, Scheme_Object *ctx); +void scheme_optimize_info_never_inline(Optimize_Info *); /* Controls for inlining algorithm: */ #define OPT_ESTIMATE_FUTURE_SIZES 1 @@ -2582,73 +2573,21 @@ void scheme_optimize_info_used_top(Optimize_Info *info); Scheme_Object *scheme_estimate_closure_size(Scheme_Object *e); Scheme_Object *scheme_no_potential_size(Scheme_Object *value); -void scheme_optimize_mutated(Optimize_Info *info, int pos); -void scheme_optimize_produces_flonum(Optimize_Info *info, int pos); -Scheme_Object *scheme_optimize_reverse(Optimize_Info *info, int pos, int unless_mutated); -int scheme_optimize_is_used(Optimize_Info *info, int pos); -int scheme_optimize_any_uses(Optimize_Info *info, int start_pos, int end_pos); -int scheme_optimize_is_mutated(Optimize_Info *info, int pos); -int scheme_optimize_is_flonum_arg(Optimize_Info *info, int pos, int depth); -int scheme_optimize_is_flonum_valued(Optimize_Info *info, int pos); - -int scheme_is_flonum_expression(Scheme_Object *expr, Optimize_Info *info); -char *scheme_get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok); -void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map); -void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2); - Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth); Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth); -Scheme_Object *scheme_clone_closure_compilation(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth); -Scheme_Object *scheme_shift_closure_compilation(Scheme_Object *obj, int delta, int after_depth); - -int scheme_closure_body_size(Scheme_Closure_Data *closure_data, int check_assign, Optimize_Info *info, int *is_leaf); -int scheme_closure_argument_flags(Scheme_Closure_Data *closure_data, int i); -int scheme_closure_has_top_level(Scheme_Closure_Data *data); - -Optimize_Info *scheme_optimize_info_add_frame(Optimize_Info *info, int orig, int current, int flags); -int scheme_optimize_info_get_shift(Optimize_Info *info, int pos); -void scheme_optimize_info_done(Optimize_Info *info); Scheme_Object *scheme_toplevel_to_flagged_toplevel(Scheme_Object *tl, int flags); -void scheme_env_make_closure_map(Optimize_Info *frame, mzshort *size, mzshort **map); -int scheme_env_uses_toplevel(Optimize_Info *frame); - int scheme_wants_flonum_arguments(Scheme_Object *rator, int argpos, int rotate_mode); int scheme_expr_produces_flonum(Scheme_Object *expr); -typedef struct Scheme_Once_Used { - Scheme_Object so; - Scheme_Object *expr; - int pos; - int vclock; - - int used; - int delta; - Optimize_Info *info; - - struct Scheme_Once_Used *next; -} Scheme_Once_Used; - -Scheme_Once_Used *scheme_make_once_used(Scheme_Object *val, int pos, int vclock, Scheme_Once_Used *prev); - -int scheme_resolve_toplevel_pos(Resolve_Info *info); -int scheme_resolve_is_toplevel_available(Resolve_Info *info); -int scheme_resolve_quote_syntax_offset(int i, Resolve_Info *info); -int scheme_resolve_quote_syntax_pos(Resolve_Info *info); -Scheme_Object *scheme_resolve_toplevel(Resolve_Info *info, Scheme_Object *expr, int keep_ready); -Scheme_Object *scheme_resolve_invent_toplevel(Resolve_Info *info); -Scheme_Object *scheme_resolve_invented_toplevel_to_defn(Resolve_Info *info, Scheme_Object *tl); -Scheme_Object *scheme_shift_toplevel(Scheme_Object *expr, int delta); -Scheme_Object *scheme_resolve_generate_stub_lift(void); -int scheme_resolve_quote_syntax(Resolve_Info *info, int oldpos); -int scheme_resolving_in_procedure(Resolve_Info *info); - -void scheme_resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs); - Scheme_Object *scheme_make_compiled_syntax(Scheme_Syntax *syntax, Scheme_Syntax_Expander *exp); +Scheme_Object *scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, + Scheme_Compile_Expand_Info *rec, int drec, + int app_position); + Scheme_Object *scheme_compile_expr(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, @@ -2663,6 +2602,13 @@ Scheme_Object *scheme_compile_list(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *scheme_compile_expr_lift_to_let(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); +Scheme_Object *scheme_pair_lifted(Scheme_Object *_ip, Scheme_Object **_ids, Scheme_Object *expr, + Scheme_Comp_Env *env); +Scheme_Object *scheme_add_lifts_as_let(Scheme_Object *obj, Scheme_Object *l, Scheme_Comp_Env *env, + Scheme_Object *orig_form, int comp_rev); + +void scheme_add_core_stop_form(int pos, Scheme_Object *sym, Scheme_Comp_Env *env); + void scheme_default_compile_rec(Scheme_Compile_Info *src, int drec); void scheme_compile_rec_done_local(Scheme_Compile_Info *src, int drec); void scheme_init_compile_recs(Scheme_Compile_Info *src, int drec, @@ -2680,20 +2626,14 @@ void scheme_init_expand_recs(Scheme_Expand_Info *src, int drec, void scheme_rec_add_certs(Scheme_Compile_Expand_Info *src, int drec, Scheme_Object *stx); -Scheme_Object *scheme_make_closure_compilation(Scheme_Comp_Env *env, - Scheme_Object *uncompiled_code, - Scheme_Compile_Info *rec, int drec); Scheme_Object *scheme_make_sequence_compilation(Scheme_Object *compiled_list, int strip_values); -Scheme_Object *scheme_optimize_closure_compilation(Scheme_Object *_data, Optimize_Info *info, int context); -Scheme_Object *scheme_resolve_closure_compilation(Scheme_Object *_data, Resolve_Info *info, - int can_lift, int convert, int just_compute_lift, - Scheme_Object *precomputed_lift); - Scheme_App_Rec *scheme_malloc_application(int n); void scheme_finish_application(Scheme_App_Rec *app); +Scheme_Sequence *scheme_malloc_sequence(int count); + Scheme_Object *scheme_jit_expr(Scheme_Object *); Scheme_Object *scheme_jit_closure(Scheme_Object *, Scheme_Object *context); void scheme_jit_fill_threadlocal_table(); @@ -2810,11 +2750,16 @@ int scheme_used_ever(Scheme_Comp_Env *env, int which); int scheme_omittable_expr(Scheme_Object *o, int vals, int fuel, int resolved, Optimize_Info *warn_info, int deeper_than); +int scheme_might_invoke_call_cc(Scheme_Object *value); +int scheme_is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator); int scheme_is_env_variable_boxed(Scheme_Comp_Env *env, int which); int scheme_get_eval_type(Scheme_Object *obj); +Scheme_Object *scheme_make_application(Scheme_Object *v); +Scheme_Object *scheme_try_apply(Scheme_Object *f, Scheme_Object *args, Scheme_Object *context); + Scheme_Object *scheme_get_stop_expander(void); void scheme_define_parse(Scheme_Object *form, @@ -2853,13 +2798,6 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, Scheme_Object *app_rator, int proc_with_refs_ok, int result_ignored, struct Validate_Clearing *vc, int tailpos, int need_flonum, Scheme_Hash_Tree *procs); -void scheme_validate_toplevel(Scheme_Object *expr, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - int skip_refs_check); -void scheme_validate_boxenv(int pos, Mz_CPort *port, - char *stack, int depth, int delta, int letlimit); int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos, int hope, @@ -2936,152 +2874,12 @@ Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o); int scheme_is_set_transformer(Scheme_Object *o); Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o); -Scheme_Object *scheme_define_values_execute(Scheme_Object *data); -Scheme_Object *scheme_ref_execute(Scheme_Object *data); -Scheme_Object *scheme_set_execute(Scheme_Object *data); -Scheme_Object *scheme_define_syntaxes_execute(Scheme_Object *expr); -Scheme_Object *scheme_define_for_syntaxes_execute(Scheme_Object *expr); -Scheme_Object *scheme_case_lambda_execute(Scheme_Object *expr); -Scheme_Object *scheme_begin0_execute(Scheme_Object *data); -Scheme_Object *scheme_apply_values_execute(Scheme_Object *data); -Scheme_Object *scheme_splice_execute(Scheme_Object *data); -Scheme_Object *scheme_bangboxenv_execute(Scheme_Object *data); Scheme_Object *scheme_top_level_require_execute(Scheme_Object *data); +Scheme_Object *scheme_case_lambda_execute(Scheme_Object *expr); -Scheme_Object *scheme_define_values_optimize(Scheme_Object *data, Optimize_Info *info, int context); -Scheme_Object *scheme_ref_optimize(Scheme_Object *data, Optimize_Info *info, int context); -Scheme_Object *scheme_set_optimize(Scheme_Object *data, Optimize_Info *info, int context); -Scheme_Object *scheme_define_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info, int context); -Scheme_Object *scheme_define_for_syntaxes_optimize(Scheme_Object *expr, Optimize_Info *info, int context); -Scheme_Object *scheme_case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context); -Scheme_Object *scheme_begin0_optimize(Scheme_Object *data, Optimize_Info *info, int context); -Scheme_Object *scheme_apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context); -Scheme_Object *scheme_module_optimize(Scheme_Object *data, Optimize_Info *info, int context); -Scheme_Object *scheme_top_level_require_optimize(Scheme_Object *data, Optimize_Info *info, int context); - -Scheme_Object *scheme_begin0_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); -Scheme_Object *scheme_set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); -Scheme_Object *scheme_apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); -Scheme_Object *scheme_case_lambda_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth); - -Scheme_Object *scheme_begin0_shift(Scheme_Object *data, int delta, int after_depth); -Scheme_Object *scheme_set_shift(Scheme_Object *data, int delta, int after_depth); -Scheme_Object *scheme_ref_shift(Scheme_Object *data, int delta, int after_depth); -Scheme_Object *scheme_case_lambda_shift(Scheme_Object *data, int delta, int after_depth); -Scheme_Object *scheme_apply_values_shift(Scheme_Object *data, int delta, int after_depth); - -Scheme_Object *scheme_define_values_resolve(Scheme_Object *data, Resolve_Info *info); -Scheme_Object *scheme_ref_resolve(Scheme_Object *data, Resolve_Info *info); -Scheme_Object *scheme_set_resolve(Scheme_Object *data, Resolve_Info *info); -Scheme_Object *scheme_define_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info); -Scheme_Object *scheme_define_for_syntaxes_resolve(Scheme_Object *expr, Resolve_Info *info); -Scheme_Object *scheme_case_lambda_resolve(Scheme_Object *expr, Resolve_Info *info); -Scheme_Object *scheme_begin0_resolve(Scheme_Object *data, Resolve_Info *info); -Scheme_Object *scheme_apply_values_resolve(Scheme_Object *data, Resolve_Info *info); -Scheme_Object *scheme_module_expr_resolve(Scheme_Object *data, Resolve_Info *info); -Scheme_Object *scheme_top_level_require_resolve(Scheme_Object *data, Resolve_Info *info); - -Scheme_Object *scheme_define_values_sfs(Scheme_Object *data, SFS_Info *info); -Scheme_Object *scheme_ref_sfs(Scheme_Object *data, SFS_Info *info); -Scheme_Object *scheme_set_sfs(Scheme_Object *data, SFS_Info *info); -Scheme_Object *scheme_define_syntaxes_sfs(Scheme_Object *expr, SFS_Info *info); -Scheme_Object *scheme_define_for_syntaxes_sfs(Scheme_Object *expr, SFS_Info *info); -Scheme_Object *scheme_case_lambda_sfs(Scheme_Object *expr, SFS_Info *info); -Scheme_Object *scheme_begin0_sfs(Scheme_Object *data, SFS_Info *info); -Scheme_Object *scheme_apply_values_sfs(Scheme_Object *data, SFS_Info *info); -Scheme_Object *scheme_bangboxenv_sfs(Scheme_Object *data, SFS_Info *info); -Scheme_Object *scheme_module_sfs(Scheme_Object *data, SFS_Info *info); -Scheme_Object *scheme_top_level_require_sfs(Scheme_Object *data, SFS_Info *info); - -void scheme_define_values_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_ref_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_set_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_case_lambda_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_begin0_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_apply_values_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_module_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); -void scheme_top_level_require_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs); - -Scheme_Object *scheme_define_values_jit(Scheme_Object *data); -Scheme_Object *scheme_ref_jit(Scheme_Object *data); -Scheme_Object *scheme_set_jit(Scheme_Object *data); -Scheme_Object *scheme_define_syntaxes_jit(Scheme_Object *expr); -Scheme_Object *scheme_define_for_syntaxes_jit(Scheme_Object *expr); -Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr); -Scheme_Object *scheme_begin0_jit(Scheme_Object *data); -Scheme_Object *scheme_apply_values_jit(Scheme_Object *data); -Scheme_Object *scheme_bangboxenv_jit(Scheme_Object *data); Scheme_Object *scheme_module_jit(Scheme_Object *data); Scheme_Object *scheme_top_level_require_jit(Scheme_Object *data); +Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr); /*========================================================================*/ /* namespaces and modules */ @@ -3306,6 +3104,8 @@ void scheme_module_force_lazy(Scheme_Env *env, int previous); int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *varname); +Scheme_Module_Exports *scheme_make_module_exports(); + Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, Scheme_Object *certs, Scheme_Object *unexp_insp, diff --git a/src/racket/src/sfs.c b/src/racket/src/sfs.c new file mode 100644 index 0000000000..f5a97ab247 --- /dev/null +++ b/src/racket/src/sfs.c @@ -0,0 +1,1272 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +/* This file implements the bytecode safe-for-space pass. + + See "eval.c" for an overview of compilation passes. */ + +#include "schpriv.h" +#include "schrunst.h" +#include "schexpobs.h" + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +void scheme_init_sfs() +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif +} + +/* For debugging and measuring the worst-case cost of sfs clears: */ +#define MAX_SFS_CLEARING 0 + +#define SFS_LOG(x) /* nothing */ + +Scheme_Object *scheme_sfs(Scheme_Object *o, SFS_Info *info, int max_let_depth) +{ + int init, i; + + SFS_LOG(printf("sfs %d\n", SCHEME_TYPE(o))); + + if (!info) { + info = scheme_new_sfs_info(max_let_depth); + } + + info->pass = 0; + info->ip = 1; + info->saved = scheme_null; + info->min_touch = -1; + info->max_touch = -1; + info->tail_pos = 1; + init = info->stackpos; + o = scheme_sfs_expr(o, info, -1); + + if (info->seqn) + scheme_signal_error("ended in the middle of an expression?"); + +# if MAX_SFS_CLEARING + info->max_nontail = info->ip; +# endif + + for (i = info->depth; i-- > init; ) { + info->max_calls[i] = info->max_nontail; + } + + { + Scheme_Object *v; + v = scheme_reverse(info->saved); + info->saved = v; + } + + info->pass = 1; + info->seqn = 0; + info->ip = 1; + info->tail_pos = 1; + info->stackpos = init; + o = scheme_sfs_expr(o, info, -1); + + return o; +} + +SFS_Info *scheme_new_sfs_info(int depth) +{ + SFS_Info *info; + int *max_used, *max_calls; + + info = MALLOC_ONE_RT(SFS_Info); + SET_REQUIRED_TAG(info->type = scheme_rt_sfs_info); + + info->depth = depth; + info->stackpos = depth; + info->tlpos = depth; + + max_used = (int *)scheme_malloc_atomic(sizeof(int) * depth); + max_calls = (int *)scheme_malloc_atomic(sizeof(int) * depth); + + memset(max_used, 0, sizeof(int) * depth); + memset(max_calls, 0, sizeof(int) * depth); + + info->max_used = max_used; + info->max_calls = max_calls; + + return info; +} + +static void scheme_sfs_save(SFS_Info *info, Scheme_Object *v) +{ + if (info->pass) + scheme_signal_error("internal error: wrong pass to save info"); + v = scheme_make_pair(v, info->saved); + info->saved = v; +} + +static Scheme_Object *scheme_sfs_next_saved(SFS_Info *info) +{ + Scheme_Object *v; + + if (!info->pass) + scheme_signal_error("internal error: wrong pass to get saved info"); + if (!SCHEME_PAIRP(info->saved)) + scheme_signal_error("internal error: no saved info"); + + v = SCHEME_CAR(info->saved); + info->saved = SCHEME_CDR(info->saved); + return v; +} + +void scheme_sfs_start_sequence(SFS_Info *info, int cnt, int last_is_tail) +{ + info->seqn += (cnt - (last_is_tail ? 1 : 0)); +} + +void scheme_sfs_push(SFS_Info *info, int cnt, int track) +{ + info->stackpos -= cnt; + + if (info->stackpos < 0) + scheme_signal_error("internal error: pushed too deep"); + + if (track) { + while (cnt--) { + scheme_sfs_used(info, cnt); + } + } +} + +void scheme_sfs_used(SFS_Info *info, int pos) +{ + if (info->pass) + return; + + pos += info->stackpos; + + if ((pos < 0) || (pos >= info->depth)) { + scheme_signal_error("internal error: stack use out of bounds"); + } + if (pos == info->tlpos) + scheme_signal_error("internal error: misuse of toplevel pointer"); + + SFS_LOG(printf("touch %d %d\n", pos, info->ip)); + + if ((info->min_touch == -1) + || (pos < info->min_touch)) + info->min_touch = pos; + if (pos > info->max_touch) + info->max_touch = pos; + + info->max_used[pos] = info->ip; +} + +Scheme_Object *scheme_sfs_add_clears(Scheme_Object *expr, Scheme_Object *clears, int pre) +{ + int len, i; + Scheme_Object *loc; + Scheme_Sequence *s; + + if (SCHEME_NULLP(clears)) + return expr; + + len = scheme_list_length(clears); + + s = scheme_malloc_sequence(len + 1); + s->so.type = (pre ? scheme_sequence_type : scheme_begin0_sequence_type); + s->count = len + 1; + s->array[pre ? len : 0] = expr; + + for (i = 0; i < len; i++) { + loc = scheme_make_local(scheme_local_type, + SCHEME_INT_VAL(SCHEME_CAR(clears)), + SCHEME_LOCAL_CLEAR_ON_READ); + s->array[i + (pre ? 0 : 1)] = loc; + clears = SCHEME_CDR(clears); + } + + return (Scheme_Object *)s; +} + +static void sfs_note_app(SFS_Info *info, Scheme_Object *rator) +{ + if (!info->pass) { + if (!info->tail_pos) { + if (SAME_OBJ(scheme_values_func, rator)) + /* no need to clear for app of `values' */ + return; + if (SCHEME_PRIMP(rator)) { + int opt; + opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; + if (opt >= SCHEME_PRIM_OPT_IMMEDIATE) + /* Don't need to clear stack before an immediate/folding call */ + return; + } + info->max_nontail = info->ip; + } else { + if (!MAX_SFS_CLEARING && (info->selfpos >= 0)) { + if (SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type)) { + if ((SCHEME_LOCAL_POS(rator) + info->stackpos) == info->selfpos) { + /* No point in clearing out any of the closure before the + tail call. */ + int i; + for (i = info->selflen; i--; ) { + if ((info->selfstart + i) != info->tlpos) + scheme_sfs_used(info, (info->selfstart - info->stackpos) + i); + } + } + } + } + } + } +} + +static Scheme_Object *sfs_application(Scheme_Object *o, SFS_Info *info) +{ + Scheme_Object *orig, *naya = NULL; + Scheme_App_Rec *app; + int i, n; + + app = (Scheme_App_Rec *)o; + n = app->num_args + 1; + + scheme_sfs_start_sequence(info, n, 0); + scheme_sfs_push(info, n-1, 0); + + for (i = 0; i < n; i++) { + orig = app->args[i]; + naya = scheme_sfs_expr(orig, info, -1); + app->args[i] = naya; + } + + sfs_note_app(info, app->args[0]); + + scheme_finish_application(app); + + return o; +} + +static Scheme_Object *sfs_application2(Scheme_Object *o, SFS_Info *info) +{ + Scheme_App2_Rec *app; + Scheme_Object *nrator, *nrand; + + app = (Scheme_App2_Rec *)o; + + scheme_sfs_start_sequence(info, 2, 0); + scheme_sfs_push(info, 1, 0); + + nrator = scheme_sfs_expr(app->rator, info, -1); + nrand = scheme_sfs_expr(app->rand, info, -1); + app->rator = nrator; + app->rand = nrand; + + sfs_note_app(info, app->rator); + + scheme_reset_app2_eval_type(app); + + return o; +} + +static Scheme_Object *sfs_application3(Scheme_Object *o, SFS_Info *info) +{ + Scheme_App3_Rec *app; + Scheme_Object *nrator, *nrand1, *nrand2; + + app = (Scheme_App3_Rec *)o; + + scheme_sfs_start_sequence(info, 3, 0); + scheme_sfs_push(info, 2, 0); + + nrator = scheme_sfs_expr(app->rator, info, -1); + nrand1 = scheme_sfs_expr(app->rand1, info, -1); + nrand2 = scheme_sfs_expr(app->rand2, info, -1); + + app->rator = nrator; + app->rand1 = nrand1; + app->rand2 = nrand2; + + sfs_note_app(info, app->rator); + + scheme_reset_app3_eval_type(app); + + return o; +} + +static Scheme_Object *sfs_sequence(Scheme_Object *o, SFS_Info *info) +{ + Scheme_Object *orig, *naya; + Scheme_Sequence *seq; + int i, n; + + seq = (Scheme_Sequence *)o; + n = seq->count; + + scheme_sfs_start_sequence(info, n, 1); + + for (i = 0; i < n; i++) { + orig = seq->array[i]; + naya = scheme_sfs_expr(orig, info, -1); + seq->array[i] = naya; + } + + return o; +} + +#define SFS_BRANCH_W 4 + +static Scheme_Object *sfs_one_branch(SFS_Info *info, int ip, + Scheme_Object *vec, int delta, + Scheme_Object *tbranch) +{ + int t_min_t, t_max_t, t_cnt, n, stackpos, i, save_nt, b_end, nt; + Scheme_Object *t_vec, *o; + Scheme_Object *clears = scheme_null; + + info->min_touch = -1; + info->max_touch = -1; + save_nt = info->max_nontail; + + SFS_LOG(printf("%d %d %s %d\n", info->pass, ip, (delta ? "else" : "then"), ip)); + + if (info->pass) { + /* Re-install max_used entries that refer to the branch */ + o = SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W]; + t_min_t = SCHEME_INT_VAL(o); + o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2]; + nt = SCHEME_INT_VAL(o); + if (nt > info->max_nontail) + info->max_nontail = nt; + if (t_min_t > -1) { + t_vec = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1]; + t_cnt = SCHEME_VEC_SIZE(t_vec); + for (i = 0; i < t_cnt; i++) { + o = SCHEME_VEC_ELS(t_vec)[i]; + if (SCHEME_INTP(o)) { + n = SCHEME_INT_VAL(o); + SFS_LOG(printf(" @%d %d\n", i + t_min_t, n)); + if (info->max_used[i + t_min_t] < n) { + SFS_LOG(printf(" |%d %d %d\n", i + t_min_t, n, info->max_nontail)); + info->max_used[i + t_min_t] = n; + info->max_calls[i + t_min_t] = info->max_nontail; + } + } + } + } + /* If the other branch has last use for something not used in this + branch, and if there's a non-tail call in this branch + of later, then we'll have to start with explicit clears. + Note that it doesn't matter whether the other branch actually + clears them (i.e., the relevant non-tail call might be only + in this branch). */ + o = SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3]; + b_end = SCHEME_INT_VAL(o); + SFS_LOG(printf(" %d %d %d %d\n", nt, ip, b_end, save_nt)); + if (((nt > (ip + 1)) && (nt < b_end)) /* => non-tail call in branch */ + || ((ip + 1) < save_nt)) { /* => non-tail call after branches */ + SFS_LOG(printf(" other\n")); + o = SCHEME_VEC_ELS(vec)[(1 - delta) * SFS_BRANCH_W]; + t_min_t = SCHEME_INT_VAL(o); + if (t_min_t > -1) { + int at_ip, pos; + t_vec = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 1]; + t_cnt = SCHEME_VEC_SIZE(t_vec); + o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 2]; + nt = SCHEME_INT_VAL(o); + o = SCHEME_VEC_ELS(vec)[((1 - delta) * SFS_BRANCH_W) + 3]; + b_end = SCHEME_INT_VAL(o); + for (i = 0; i < t_cnt; i++) { + o = SCHEME_VEC_ELS(t_vec)[i]; + if (SCHEME_INTP(o)) { + n = SCHEME_INT_VAL(o); + pos = i + t_min_t; + at_ip = info->max_used[pos]; + SFS_LOG(printf(" ?%d %d %d\n", pos, n, at_ip)); + /* is last use in other branch? */ + if (((!delta && (at_ip == ip)) + || (delta && (at_ip == n)))) { + /* Yes, so add clear */ + SFS_LOG(printf(" !%d %d %d\n", pos, n, at_ip)); + pos -= info->stackpos; + clears = scheme_make_pair(scheme_make_integer(pos), + clears); + } + } + } + } + } + } + + stackpos = info->stackpos; + + tbranch = scheme_sfs_expr(tbranch, info, -1); + + if (info->pass) + info->max_nontail = save_nt; +# if MAX_SFS_CLEARING + else + info->max_nontail = info->ip; +# endif + + tbranch = scheme_sfs_add_clears(tbranch, clears, 1); + + if (!info->pass) { + t_min_t = info->min_touch; + t_max_t = info->max_touch; + if (t_min_t < stackpos) + t_min_t = stackpos; + if (t_max_t < stackpos) + t_max_t = -1; + SFS_LOG(printf("%d %s %d [%d,%d] /%d\n", info->pass, (delta ? "else" : "then"), ip, + t_min_t, t_max_t, stackpos)); + if (t_max_t < 0) { + t_min_t = -1; + t_vec = scheme_false; + } else { + t_cnt = t_max_t - t_min_t + 1; + t_vec = scheme_make_vector(t_cnt, NULL); + for (i = 0; i < t_cnt; i++) { + n = info->max_used[i + t_min_t]; + SFS_LOG(printf("%d %s %d %d -> %d/%d\n", info->pass, (delta ? "else" : "then"), ip, + i + t_min_t, n, info->max_calls[i+ t_min_t])); + if (n > ip) { + SCHEME_VEC_ELS(t_vec)[i] = scheme_make_integer(n); + info->max_used[i + t_min_t] = ip; + } else { + SCHEME_VEC_ELS(t_vec)[i] = scheme_false; + } + } + } + SCHEME_VEC_ELS(vec)[delta * SFS_BRANCH_W] = scheme_make_integer(t_min_t); + SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 1] = t_vec; + SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 2] = scheme_make_integer(info->max_nontail); + SCHEME_VEC_ELS(vec)[(delta * SFS_BRANCH_W) + 3] = scheme_make_integer(info->ip); + } + + memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); + memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); + + info->stackpos = stackpos; + + return tbranch; +} + +static Scheme_Object *sfs_branch(Scheme_Object *o, SFS_Info *info) +{ + Scheme_Branch_Rec *b; + Scheme_Object *t, *tb, *fb, *vec; + int ip, min_t, max_t; + + b = (Scheme_Branch_Rec *)o; + + scheme_sfs_start_sequence(info, 1, 0); + + t = scheme_sfs_expr(b->test, info, -1); + + ip = info->ip; + info->ip++; + /* Use ip to represent all uses in the two branches. + Use ip+1 to represent all non-tail calls in the two branches. */ + + min_t = info->min_touch; + max_t = info->max_touch; + + SFS_LOG(printf(" after test: %d %d\n", min_t, max_t)); + + if (!info->pass) { + vec = scheme_make_vector(SFS_BRANCH_W * 2, NULL); + scheme_sfs_save(info, vec); + } else { + vec = scheme_sfs_next_saved(info); + } + + tb = sfs_one_branch(info, ip, vec, 0, b->tbranch); + + if (!info->pass) { + if ((min_t == -1) + || ((info->min_touch > -1) && (info->min_touch < min_t))) + min_t = info->min_touch; + if (info->max_touch > max_t) + max_t = info->max_touch; + if (info->max_nontail > ip + 1) + info->max_nontail = ip + 1; + } + + fb = sfs_one_branch(info, ip, vec, 1, b->fbranch); + + if (!info->pass) { + if ((min_t == -1) + || ((info->min_touch > -1) && (info->min_touch < min_t))) + min_t = info->min_touch; + if (info->max_touch > max_t) + max_t = info->max_touch; + if (info->max_nontail > ip + 1) + info->max_nontail = ip + 1; + } + + SFS_LOG(printf(" done if: %d %d\n", min_t, max_t)); + + info->min_touch = min_t; + info->max_touch = max_t; + + b->test = t; + b->tbranch = tb; + b->fbranch = fb; + + return o; +} + +static Scheme_Object *sfs_let_value(Scheme_Object *o, SFS_Info *info) +{ + Scheme_Let_Value *lv = (Scheme_Let_Value *)o; + Scheme_Object *body, *rhs, *clears = scheme_null; + int i, pos; + + scheme_sfs_start_sequence(info, 2, 1); + + rhs = scheme_sfs_expr(lv->value, info, -1); + + if (!info->pass + || (info->ip < info->max_nontail)) { + for (i = 0; i < lv->count; i++) { + pos = lv->position + i; + if (!info->pass) + scheme_sfs_used(info, pos); + else { + int spos; + spos = pos + info->stackpos; + if ((info->max_used[spos] == info->ip) + && (info->max_calls[spos] > info->ip)) { + /* No one is using the id after we set it. + We still need to set it, in case it's boxed and shared, + but then remove the binding or box. */ + clears = scheme_make_pair(scheme_make_integer(pos), + clears); + } + } + } + } + + body = scheme_sfs_expr(lv->body, info, -1); + + body = scheme_sfs_add_clears(body, clears, 1); + + lv->value = rhs; + lv->body = body; + + return o; +} + +static Scheme_Object *sfs_let_one(Scheme_Object *o, SFS_Info *info) +{ + Scheme_Let_One *lo = (Scheme_Let_One *)o; + Scheme_Object *body, *rhs, *vec; + int pos, save_mnt, ip, et; + int unused = 0; + + scheme_sfs_start_sequence(info, 2, 1); + + scheme_sfs_push(info, 1, 1); + ip = info->ip; + pos = info->stackpos; + save_mnt = info->max_nontail; + + if (!info->pass) { + vec = scheme_make_vector(3, NULL); + scheme_sfs_save(info, vec); + } else { + vec = scheme_sfs_next_saved(info); + if (SCHEME_VEC_SIZE(vec) != 3) + scheme_signal_error("internal error: bad vector length"); + info->max_used[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[0]); + info->max_calls[pos] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[1]); + info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[2]); + } + + rhs = scheme_sfs_expr(lo->value, info, -1); + body = scheme_sfs_expr(lo->body, info, -1); + +# if MAX_SFS_CLEARING + if (!info->pass) + info->max_nontail = info->ip; +# endif + + if (!info->pass) { + int n; + info->max_calls[pos] = info->max_nontail; + n = info->max_used[pos]; + SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(n); + n = info->max_calls[pos]; + SCHEME_VEC_ELS(vec)[1] = scheme_make_integer(n); + SCHEME_VEC_ELS(vec)[2] = scheme_make_integer(info->max_nontail); + } else { + info->max_nontail = save_mnt; + + if (info->max_used[pos] <= ip) { + /* No one is using it, so don't actually push the value at run time + (but keep the check that the result is single-valued). + The optimizer normally would have converted away the binding, but + it might not because (1) it was introduced late by inlining, + or (2) the rhs expression doesn't always produce a single + value. */ + if (scheme_omittable_expr(rhs, 1, -1, 1, NULL, -1)) { + rhs = scheme_false; + } else if ((ip < info->max_calls[pos]) + && SAME_TYPE(SCHEME_TYPE(rhs), scheme_toplevel_type)) { + /* Unusual case: we can't just drop the global-variable access, + because it might be undefined, but we don't need the value, + and we want to avoid an SFS clear in the interpreter loop. + So, bind #f and then access in the global in a `begin'. */ + Scheme_Sequence *s; + s = scheme_malloc_sequence(2); + s->so.type = scheme_sequence_type; + s->count = 2; + s->array[0] = rhs; + s->array[1] = body; + body = (Scheme_Object *)s; + rhs = scheme_false; + } + unused = 1; + } + } + + lo->value = rhs; + lo->body = body; + + et = scheme_get_eval_type(lo->value); + SCHEME_LET_EVAL_TYPE(lo) = (et + | (unused ? 0 : (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM)) + | (unused ? LET_ONE_UNUSED : 0)); + + return o; +} + +static Scheme_Object *sfs_let_void(Scheme_Object *o, SFS_Info *info) +{ + Scheme_Let_Void *lv = (Scheme_Let_Void *)o; + Scheme_Object *body; + int i, pos, save_mnt; + Scheme_Object *vec; + + scheme_sfs_push(info, lv->count, 1); + pos = info->stackpos; + save_mnt = info->max_nontail; + + if (!info->pass) { + vec = scheme_make_vector(lv->count + 1, NULL); + scheme_sfs_save(info, vec); + } else { + vec = scheme_sfs_next_saved(info); + if (!SCHEME_VECTORP(vec)) + scheme_signal_error("internal error: not a vector"); + for (i = 0; i < lv->count; i++) { + info->max_used[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[i]); + info->max_calls[pos + i] = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]); + } + info->max_nontail = SCHEME_INT_VAL(SCHEME_VEC_ELS(vec)[lv->count]); + } + + body = scheme_sfs_expr(lv->body, info, -1); + +# if MAX_SFS_CLEARING + if (!info->pass) + info->max_nontail = info->ip; +# endif + + if (!info->pass) { + int n; + SCHEME_VEC_ELS(vec)[lv->count] = scheme_make_integer(info->max_nontail); + for (i = 0; i < lv->count; i++) { + n = info->max_used[pos + i]; + SCHEME_VEC_ELS(vec)[i] = scheme_make_integer(n); + } + } else { + info->max_nontail = save_mnt; + } + + lv->body = body; + + return o; +} + +static Scheme_Object *sfs_letrec(Scheme_Object *o, SFS_Info *info) +{ + Scheme_Letrec *lr = (Scheme_Letrec *)o; + Scheme_Object **procs, *v, *clears = scheme_null; + int i, count; + + count = lr->count; + + scheme_sfs_start_sequence(info, count + 1, 1); + + procs = lr->procs; + + for (i = 0; i < count; i++) { + v = scheme_sfs_expr(procs[i], info, i); + + if (SAME_TYPE(SCHEME_TYPE(v), scheme_begin0_sequence_type)) { + /* Some clearing actions were added to the closure. + Lift them out. */ + int j; + Scheme_Sequence *cseq = (Scheme_Sequence *)v; + for (j = 1; j < cseq->count; j++) { + int pos; + pos = SCHEME_LOCAL_POS(cseq->array[j]); + clears = scheme_make_pair(scheme_make_integer(pos), clears); + } + v = cseq->array[0]; + } + procs[i] = v; + } + + v = scheme_sfs_expr(lr->body, info, -1); + + v = scheme_sfs_add_clears(v, clears, 1); + + lr->body = v; + + return o; +} + +static Scheme_Object *sfs_wcm(Scheme_Object *o, SFS_Info *info) +{ + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)o; + Scheme_Object *k, *v, *b; + + scheme_sfs_start_sequence(info, 3, 1); + + k = scheme_sfs_expr(wcm->key, info, -1); + v = scheme_sfs_expr(wcm->val, info, -1); + b = scheme_sfs_expr(wcm->body, info, -1); + + wcm->key = k; + wcm->val = v; + wcm->body = b; + + return o; +} + +/*========================================================================*/ +/* other syntax */ +/*========================================================================*/ + +static Scheme_Object * +define_values_sfs(Scheme_Object *data, SFS_Info *info) +{ + Scheme_Object *e; + scheme_sfs_start_sequence(info, 1, 0); + e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); + SCHEME_VEC_ELS(data)[0] = e; + return data; +} + +static Scheme_Object * +set_sfs(Scheme_Object *data, SFS_Info *info) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; + Scheme_Object *var, *val; + + var = sb->var; + val = sb->val; + + scheme_sfs_start_sequence(info, 2, 0); + + val = scheme_sfs_expr(val, info, -1); + var = scheme_sfs_expr(var, info, -1); + + sb->var = var; + sb->val = val; + + return (Scheme_Object *)sb; +} + +static Scheme_Object * +ref_sfs(Scheme_Object *data, SFS_Info *info) +{ + Scheme_Object *a_naya; + Scheme_Object *b_naya; + + scheme_sfs_start_sequence(info, 1, 0); + a_naya = scheme_sfs_expr(SCHEME_PTR1_VAL(data), info, -1); + b_naya = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); + SCHEME_PTR1_VAL(data) = a_naya; + SCHEME_PTR2_VAL(data) = b_naya; + + return data; +} + +static Scheme_Object * +apply_values_sfs(Scheme_Object *data, SFS_Info *info) +{ + Scheme_Object *f, *e; + + f = SCHEME_PTR1_VAL(data); + e = SCHEME_PTR2_VAL(data); + + scheme_sfs_start_sequence(info, 2, 0); + + f = scheme_sfs_expr(f, info, -1); + e = scheme_sfs_expr(e, info, -1); + + SCHEME_PTR1_VAL(data) = f; + SCHEME_PTR2_VAL(data) = e; + + return data; +} + +static Scheme_Object * +case_lambda_sfs(Scheme_Object *expr, SFS_Info *info) +{ + Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; + Scheme_Object *le, *clears = scheme_null; + int i; + + scheme_sfs_start_sequence(info, seq->count, 0); + + for (i = 0; i < seq->count; i++) { + le = seq->array[i]; + le = scheme_sfs_expr(le, info, -1); + if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) { + /* Some clearing actions were added to the closure. + Lift them out. */ + int j; + Scheme_Sequence *cseq = (Scheme_Sequence *)le; + if (!cseq->count) + scheme_signal_error("internal error: empty sequence"); + for (j = 1; j < cseq->count; j++) { + int pos; + pos = SCHEME_LOCAL_POS(cseq->array[j]); + clears = scheme_make_pair(scheme_make_integer(pos), clears); + } + le = cseq->array[0]; + } + if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type) + && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) { + scheme_signal_error("internal error: not a lambda for case-lambda: %d", + SCHEME_TYPE(le)); + } + seq->array[i] = le; + } + + if (!SCHEME_NULLP(clears)) { + return scheme_sfs_add_clears(expr, clears, 0); + } else + return expr; +} + +static Scheme_Object *bangboxenv_sfs(Scheme_Object *data, SFS_Info *info) +{ + Scheme_Object *e; + int spos, drop; + + spos = SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)) + info->stackpos; + if (info->pass + && (info->max_used[spos] < info->ip)) + /* Not used, so don't bother boxing. In fact, the original value + might be cleared already, so we wan't legally box anymore. */ + drop = 1; + else + drop = 0; + + e = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); + + if (drop) + return e; + else { + SCHEME_PTR2_VAL(data) = e; + return data; + } +} + +static Scheme_Object * +begin0_sfs(Scheme_Object *obj, SFS_Info *info) +{ + int i, cnt; + + cnt = ((Scheme_Sequence *)obj)->count; + + scheme_sfs_start_sequence(info, cnt, 0); + + for (i = 0; i < cnt; i++) { + Scheme_Object *le; + le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1); + ((Scheme_Sequence *)obj)->array[i] = le; + } + + return obj; +} + +static Scheme_Object *do_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) +{ + Scheme_Object *e; + + if (!info->pass) { + int depth; + depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); + info = scheme_new_sfs_info(depth); + e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth); + SCHEME_VEC_ELS(data)[0] = e; + } + + return data; +} + +static Scheme_Object *define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) +{ + return do_define_syntaxes_sfs(data, info); +} + +static Scheme_Object *define_for_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) +{ + return do_define_syntaxes_sfs(data, info); +} + +/*========================================================================*/ +/* closures */ +/*========================================================================*/ + +static Scheme_Object *sfs_closure(Scheme_Object *expr, SFS_Info *info, int self_pos) +{ + Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; + Scheme_Object *code; + int i, size, has_tl = 0; + + size = data->closure_size; + if (size) { + if (info->stackpos + data->closure_map[size - 1] == info->tlpos) { + has_tl = 1; + --size; + } + } + + if (!info->pass) { + for (i = size; i--; ) { + scheme_sfs_used(info, data->closure_map[i]); + } + } else { + /* Check whether we need to zero out any stack positions + after capturing them in a closure: */ + Scheme_Object *clears = scheme_null; + + if (info->ip < info->max_nontail) { + int pos, ip; + for (i = size; i--; ) { + pos = data->closure_map[i] + info->stackpos; + if (pos < info->depth) { + ip = info->max_used[pos]; + if ((ip == info->ip) + && (ip < info->max_calls[pos])) { + pos -= info->stackpos; + clears = scheme_make_pair(scheme_make_integer(pos), + clears); + } + } + } + } + + return scheme_sfs_add_clears(expr, clears, 0); + } + + if (!(SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SFS)) { + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_SFS; + info = scheme_new_sfs_info(data->max_let_depth); + scheme_sfs_push(info, data->closure_size + data->num_params, 1); + + if (has_tl) + info->tlpos = info->stackpos + data->closure_size - 1; + + if (self_pos >= 0) { + for (i = size; i--; ) { + if (data->closure_map[i] == self_pos) { + info->selfpos = info->stackpos + i; + info->selfstart = info->stackpos; + info->selflen = data->closure_size; + break; + } + } + } + + code = scheme_sfs(data->code, info, data->max_let_depth); + + /* If any arguments go unused, and if there's a non-tail, + non-immediate call in the body, then we flush the + unused arguments at the start of the body. We assume that + the closure values are used (otherwise they wouldn't + be in the closure). */ + if (info->max_nontail) { + int i, pos, cnt; + Scheme_Object *clears = scheme_null; + + cnt = data->num_params; + for (i = 0; i < cnt; i++) { + pos = data->max_let_depth - (cnt - i); + if (!info->max_used[pos]) { + pos = i + data->closure_size; + clears = scheme_make_pair(scheme_make_integer(pos), + clears); + } + } + + if (SCHEME_PAIRP(clears)) + code = scheme_sfs_add_clears(code, clears, 1); + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_NEED_REST_CLEAR; + } + + data->code = code; + } + + return expr; +} + +/*========================================================================*/ +/* module */ +/*========================================================================*/ + +static Scheme_Object * +module_sfs(Scheme_Object *data, SFS_Info *old_info) +{ + Scheme_Module *m = (Scheme_Module *)data; + Scheme_Object *e, *ex; + SFS_Info *info; + int i, cnt, let_depth; + + if (!old_info->for_mod) { + if (old_info->pass) + return data; + + info = scheme_new_sfs_info(m->max_let_depth); + info->for_mod = 1; + scheme_sfs(data, info, m->max_let_depth); + return data; + } + + info = old_info; + + cnt = SCHEME_VEC_SIZE(m->body); + scheme_sfs_start_sequence(info, cnt, 0); + + for (i = 0; i < cnt; i++) { + e = scheme_sfs_expr(SCHEME_VEC_ELS(m->body)[i], info, -1); + SCHEME_VEC_ELS(m->body)[i] = e; + } + + if (!info->pass) { + cnt = SCHEME_VEC_SIZE(m->et_body); + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(m->et_body)[i]; + + let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); + ex = SCHEME_VEC_ELS(e)[1]; + + info = scheme_new_sfs_info(let_depth); + ex = scheme_sfs(ex, info, let_depth); + SCHEME_VEC_ELS(e)[1] = ex; + } + } + + return data; +} + +static Scheme_Object * +top_level_require_sfs(Scheme_Object *data, SFS_Info *rslv) +{ + return data; +} + +/*========================================================================*/ +/* expressions */ +/*========================================================================*/ + +Scheme_Object *scheme_sfs_expr(Scheme_Object *expr, SFS_Info *info, int closure_self_pos) +{ + Scheme_Type type = SCHEME_TYPE(expr); + int seqn, stackpos, tp; + + seqn = info->seqn; + stackpos = info->stackpos; + tp = info->tail_pos; + if (seqn) { + info->seqn = 0; + info->tail_pos = 0; + } + info->ip++; + + switch (type) { + case scheme_local_type: + case scheme_local_unbox_type: + if (!info->pass) + scheme_sfs_used(info, SCHEME_LOCAL_POS(expr)); + else if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) { + int pos, at_ip; + pos = SCHEME_LOCAL_POS(expr); + at_ip = info->max_used[info->stackpos + pos]; + if (at_ip < info->max_calls[info->stackpos + pos]) { + if (at_ip == info->ip) { + /* Clear on read: */ + expr = scheme_make_local(type, pos, SCHEME_LOCAL_CLEAR_ON_READ); + } else { + /* Someone else clears it: */ + expr = scheme_make_local(type, pos, SCHEME_LOCAL_OTHER_CLEARS); + } + } else { +# if MAX_SFS_CLEARING + scheme_signal_error("should have been cleared somewhere"); +# endif + } + } + break; + case scheme_application_type: + expr = sfs_application(expr, info); + break; + case scheme_application2_type: + expr = sfs_application2(expr, info); + break; + case scheme_application3_type: + expr = sfs_application3(expr, info); + break; + case scheme_sequence_type: + case scheme_splice_sequence_type: + expr = sfs_sequence(expr, info); + break; + case scheme_branch_type: + expr = sfs_branch(expr, info); + break; + case scheme_with_cont_mark_type: + expr = sfs_wcm(expr, info); + break; + case scheme_unclosed_procedure_type: + expr = sfs_closure(expr, info, closure_self_pos); + break; + case scheme_let_value_type: + expr = sfs_let_value(expr, info); + break; + case scheme_let_void_type: + expr = sfs_let_void(expr, info); + break; + case scheme_letrec_type: + expr = sfs_letrec(expr, info); + break; + case scheme_let_one_type: + expr = sfs_let_one(expr, info); + break; + case scheme_closure_type: + { + Scheme_Closure *c = (Scheme_Closure *)expr; + if (ZERO_SIZED_CLOSUREP(c)) { + Scheme_Object *code; + code = sfs_closure((Scheme_Object *)c->code, info, closure_self_pos); + if (SAME_TYPE(SCHEME_TYPE(code), scheme_begin0_sequence_type)) { + Scheme_Sequence *seq = (Scheme_Sequence *)code; + c->code = (Scheme_Closure_Data *)seq->array[0]; + seq->array[0] = expr; + expr = code; + } else { + c->code = (Scheme_Closure_Data *)code; + } + } + } + break; + case scheme_toplevel_type: + { + int c = SCHEME_TOPLEVEL_DEPTH(expr); + if (info->stackpos + c != info->tlpos) + scheme_signal_error("toplevel access not at expected place"); + } + break; + case scheme_case_closure_type: + { + /* FIXME: maybe need to handle eagerly created closure */ + } + break; + case scheme_define_values_type: + expr = define_values_sfs(expr, info); + break; + case scheme_define_syntaxes_type: + expr = define_for_syntaxes_sfs(expr, info); + break; + case scheme_define_for_syntax_type: + expr = define_syntaxes_sfs(expr, info); + break; + case scheme_set_bang_type: + expr = set_sfs(expr, info); + break; + case scheme_boxenv_type: + expr = bangboxenv_sfs(expr, info); + break; + case scheme_begin0_sequence_type: + expr = begin0_sfs(expr, info); + break; + case scheme_require_form_type: + expr = top_level_require_sfs(expr, info); + break; + case scheme_varref_form_type: + expr = ref_sfs(expr, info); + break; + case scheme_apply_values_type: + expr = apply_values_sfs(expr, info); + break; + case scheme_case_lambda_sequence_type: + expr = case_lambda_sfs(expr, info); + break; + case scheme_module_type: + expr = module_sfs(expr, info); + break; + default: + break; + } + + info->ip++; + + if (seqn) { + info->seqn = seqn - 1; + memset(info->max_used + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); + memset(info->max_calls + info->stackpos, 0, (stackpos - info->stackpos) * sizeof(int)); + info->stackpos = stackpos; + info->tail_pos = tp; + } + + return expr; +} + +/*========================================================================*/ +/* precise GC traversers */ +/*========================================================================*/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#define MARKS_FOR_SFS_C +#include "mzmark.c" + +static void register_traversers(void) +{ + GC_REG_TRAV(scheme_rt_sfs_info, mark_sfs_info); +} + +END_XFORM_SKIP; + +#endif diff --git a/src/racket/src/stxobj.c b/src/racket/src/stxobj.c deleted file mode 100644 index e162d1c8f0..0000000000 --- a/src/racket/src/stxobj.c +++ /dev/null @@ -1,9411 +0,0 @@ -/* - Racket - Copyright (c) 2004-2011 PLT Scheme Inc. - Copyright (c) 2000-2001 Matthew Flatt - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301 USA. -*/ - -#include "schpriv.h" -#include "schmach.h" -#include "schexpobs.h" - -/* The implementation of syntax objects is extremely complex due to - two levels of optimization: - - 1. Different kinds of binding are handled in different ways, - because they'll have different usage patterns. For example, - module-level bindings are handled differently than local - bindings, because modules can't be nested. - - 2. To save time and space, the data structures involved have lots - of caches, and syntax objects to be marshaled undergo a - simplification pass. - - In addition, the need to marshal syntax objects to bytecode - introduces some other complications. */ - -ROSYM static Scheme_Object *source_symbol; /* uninterned! */ -ROSYM static Scheme_Object *share_symbol; /* uninterned! */ -ROSYM static Scheme_Object *origin_symbol; -ROSYM static Scheme_Object *lexical_symbol; -ROSYM static Scheme_Object *protected_symbol; -ROSYM static Scheme_Object *nominal_id_symbol; - -READ_ONLY static Scheme_Stx_Srcloc *empty_srcloc; -READ_ONLY static Scheme_Object *empty_simplified; -READ_ONLY static Scheme_Object *no_nested_inactive_certs; -READ_ONLY static Scheme_Object *no_nested_active_certs; -READ_ONLY static Scheme_Object *no_nested_certs; - -THREAD_LOCAL_DECL(static Scheme_Object *nominal_ipair_cache); -THREAD_LOCAL_DECL(static Scheme_Object *mark_id); -THREAD_LOCAL_DECL(static Scheme_Object *current_rib_timestamp); -THREAD_LOCAL_DECL(static Scheme_Hash_Table *quick_hash_table); -THREAD_LOCAL_DECL(static Scheme_Object *last_phase_shift); -THREAD_LOCAL_DECL(static Scheme_Object *unsealed_dependencies); -THREAD_LOCAL_DECL(static Scheme_Hash_Table *id_marks_ht); /* a cache */ -THREAD_LOCAL_DECL(static Scheme_Hash_Table *than_id_marks_ht); /* a cache */ -THREAD_LOCAL_DECL(static Scheme_Bucket_Table *interned_skip_ribs); - - -static Scheme_Object *syntax_p(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv); -static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_line(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_col(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_span(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_src(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_property(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); - -static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_templ_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv); -static Scheme_Object *module_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv); -static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv); -static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv); -static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv); -static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv); - -static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv); - -static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active); - -static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj); -static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj, Scheme_Object *insp); - -#ifdef MZ_PRECISE_GC -static void register_traversers(void); -#endif - -static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark); -static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks); -static struct Scheme_Cert *cons_cert(Scheme_Object *mark, Scheme_Object *modidx, - Scheme_Object *insp, Scheme_Object *key, - struct Scheme_Cert *next_cert); -static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int len); -static void preemptive_chunk(Scheme_Stx *stx); - -#define CONS scheme_make_pair -#define ICONS scheme_make_pair - -#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) -#define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj)))) - -XFORM_NONGCING static int prefab_p(Scheme_Object *o) -{ - if (SCHEME_STRUCTP(o)) { - if (((Scheme_Structure *)o)->stype->prefab_key) - if (MZ_OPT_HASH_KEY(&((Scheme_Structure *)o)->stype->iso) & STRUCT_TYPE_ALL_IMMUTABLE) - return 1; - } - return 0; -} - -#define STX_KEY(stx) MZ_OPT_HASH_KEY(&(stx)->iso) - -typedef struct Module_Renames { - Scheme_Object so; /* scheme_rename_table_type */ - char kind, needs_unmarshal; - char sealed; /* 1 means bound won't change; 2 means unbound won't change, either */ - Scheme_Object *phase; - Scheme_Object *set_identity; - Scheme_Hash_Table *ht; /* localname -> modidx OR - (cons modidx exportname) OR - (cons modidx nominal_modidx) OR - (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR - (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) OR - (cons insp localname) OR - (cons (cons insp insp) localname) - nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase) - import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */ - Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */ - Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase_and_marks)) - phase_and_marks -> phase-index-int OR - (cons (nonempty-listof mark) phase-index-int) - like nomarshal ht, but shared from provider */ - Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module; - this table maps a top-level-bound identifier with a non-empty mark - set to a gensym created for the binding */ - Scheme_Object *unmarshal_info; /* stores some renamings as information needed to consult - imported modules and restore renames from their exports */ - Scheme_Hash_Table *free_id_renames; /* like `ht', but only for free-id=? checking, - and targets can also include: - id => resolve id (but cache if possible; never appears after simplifying) - (box (cons sym #f)) => top-level binding - (box (cons sym sym)) => lexical binding */ -} Module_Renames; - -static void unmarshal_rename(Module_Renames *mrn, - Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, - Scheme_Hash_Table *export_registry); - -typedef struct Module_Renames_Set { - Scheme_Object so; /* scheme_rename_table_set_type */ - char kind, sealed; - Scheme_Object *set_identity; - Module_Renames *rt, *et; - Scheme_Hash_Table *other_phases; - Scheme_Object *share_marked_names; /* a Module_Renames_Set */ -} Module_Renames_Set; - -typedef struct Scheme_Cert { - Scheme_Inclhash_Object iso; - Scheme_Object *mark; - Scheme_Object *modidx; - Scheme_Object *insp; - Scheme_Object *key; - Scheme_Object *mapped; /* Indicates which mark+key combinations are in - this chain. The table is created for every 16 - items in the list. For a power of 2, all items - in the rest of the chain are in the table, and - the "next" pointer is NULL. For 2^n + 2^m, then - 2^m items are in the table, and so on. Overall, the - chain's total size if O(n * lg n) for a chain of - length n, and lookup for a mark+key pair is - O(lg n). */ - int depth; - struct Scheme_Cert *next; -} Scheme_Cert; - -#define CERT_NO_KEY(c) (MZ_OPT_HASH_KEY(&(c)->iso) & 0x1) -#define CERT_SET_NO_KEY(c) (MZ_OPT_HASH_KEY(&(c)->iso) |= 0x1) - -/* Certs encoding: - - NULL: no inactive or active certs; - maybe inactive certs in nested parts - - rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); - maybe inactive certs in nested parts - Use flags 0x1 and 02 to indicate no inactive or active certs in nested parts */ -#define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL)) -#define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL)) -static Scheme_Object *stx_strip_certs(Scheme_Object *o, Scheme_Cert **cp, int active); - -#define SCHEME_NO_INACTIVE_SUBS_P(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1) -#define SCHEME_NO_ACTIVE_SUBS_P(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x2) -#define SCHEME_SET_NO_X_SUBS(obj, flag) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= flag) -#define SCHEME_SET_NO_INACTIVE_SUBS(obj) SCHEME_SET_NO_X_SUBS(obj, 0x1) -#define SCHEME_SET_NO_ACTIVE_SUBS(obj) SCHEME_SET_NO_X_SUBS(obj, 0x2) - -#define SCHEME_RENAME_LEN(vec) ((SCHEME_VEC_SIZE(vec) - 2) >> 1) - -typedef struct Scheme_Lexical_Rib { - Scheme_Object so; - Scheme_Object *rename; /* a vector for a lexical rename */ - Scheme_Object *timestamp; - int *sealed; - Scheme_Object *mapped_names; /* only in the initial link; int or hash table */ - struct Scheme_Lexical_Rib *next; -} Scheme_Lexical_Rib; - -#define SCHEME_RENAMESP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_type)) -#define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type)) - -#define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) -#define SCHEME_RIB_DELIMP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type)) - -#define SCHEME_PRUNEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_prune_context_type)) - -XFORM_NONGCING static int is_member(Scheme_Object *a, Scheme_Object *l) -{ - while (SCHEME_PAIRP(l)) { - if (SAME_OBJ(a, SCHEME_CAR(l))) - return 1; - l = SCHEME_CDR(l); - } - return 0; -} - -static int is_rename_inspector_info(Scheme_Object *v) -{ - return (SAME_TYPE(SCHEME_TYPE(v), scheme_inspector_type) - || (SCHEME_PAIRP(v) - && SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_inspector_type) - && SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(v)), scheme_inspector_type))); -} - -/* Wraps: - - A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a - "vector" (a scheme_wrap_chunk_type) of wrap-elems. - - Each wrap-elem has one of several shapes: - - - A wrap-elem <+num> is a mark - - - A wrap-elem <-num> is a certificate-only mark (doesn't conttribute to - id equivalence) - - - A wrap-elem (vector ..._0 ..._0) is a lexical rename - env (sym var : - ->pos) void => not yet computed - or #f sym => var-resolved is answer to replace #f - for nozero skipped ribs - (rlistof (rcons skipped sym)) => generalization of sym - (mcons var-resolved next) => depends on unsealed rib, - will be cleared when rib set - or: - (cons (cons )) => - free-id=? renaming to on match - - A wrap-elem (vector ..._0 ..._0) is also a lexical rename - bool var resolved: sym or (cons ), - where is module/lexical binding info: - (cons #f) => top-level binding - (cons ) => lexical binding - (free-eq-info ...) => module-binding - where the variables have already been resolved and filtered (no mark - or lexical-env comparison needed with the remaining wraps) - - - A wrap-elem (make-rib vector rib) - is an extensible set of lexical renames; it is the same as - having the vectors inline in place of the rib, except that - new vectors can be added imperatively; simplification turns this - into a vector - - - A wrap-elem (make-rib-delimiter ) - appears in pairs around rib elements; the deeper is just a - bracket, while the shallow one contains a non-empty list of - ribs; for each environment name defined within the set of - ribs, no rib within the set can build on a binding to that - environment past the end delimiter; this is used by `local-expand' - when given a list of ribs, and simplifcation eliminates - rib delimiters - - - A wrap-elem (make-prune ) - restricts binding information to that relevant for - as a datum - - - A wrap-elem is a module rename set - the hash table maps renamed syms to modname-srcname pairs - - - A wrap-elem is a set of s for - different phases. - - - A wrap-elem is a chain-specific cache; it maps - identifiers to #t, and 0 to a deeper part of the chain; a - resolution for an identifier can safely skip to the deeper - part if the identifer does not have a mapping; this skips - simple lexical renames (not ribs) and marks, only, and it's - inserted into a chain heuristically - - - A wrap-elem (box (vector )) - is a phase shift by , remapping the first to the - second ; the part is for finding - modules to unmarshal import renamings - - [Don't add a pair case, because sometimes we test for element - versus list-of-element.] - - The lazy_prefix field of a syntax object keeps track of how many of - the first wraps (items and chunks in the list) need to be propagated - to sub-syntax. */ - -#define IS_POSMARK(x) (SCHEME_INTP(x) ? (SCHEME_INT_VAL(x) >= 0) : SCHEME_BIGPOS(x)) -#define SCHEME_MARKP(x) (SCHEME_INTP(x) || SCHEME_BIGNUMP(x)) - -XFORM_NONGCING static int nom_mod_p(Scheme_Object *p) -{ - p = SCHEME_CDR(p); - return !SCHEME_PAIRP(p) && !SCHEME_SYMBOLP(p); -} - -/*========================================================================*/ -/* wrap chunks */ -/*========================================================================*/ - -typedef struct { - Scheme_Type type; - mzshort len; - Scheme_Object *a[1]; -} Wrap_Chunk; - -#define MALLOC_WRAP_CHUNK(n) (Wrap_Chunk *)scheme_malloc_tagged(sizeof(Wrap_Chunk) + ((n - 1) * sizeof(Scheme_Object *))) - -/* Macros for iterating over the elements of a wrap. */ - -typedef struct { - Scheme_Object *l; - Scheme_Object *a; - int is_limb; - int pos; -} Wrap_Pos; - -XFORM_NONGCING static void WRAP_POS_SET_FIRST(Wrap_Pos *w) -{ - if (!SCHEME_NULLP(w->l)) { - Scheme_Object *a; - a = SCHEME_CAR(w->l); - if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { - w->is_limb = 1; - w->pos = 0; - w->a = ((Wrap_Chunk *)a)->a[0]; - } else { - w->is_limb = 0; - w->a = a; - } - } - /* silence gcc "may be used uninitialized in this function" warnings */ - else { - w->a = NULL; - w->is_limb = 0; - } -} - -XFORM_NONGCING static MZ_INLINE void DO_WRAP_POS_INC(Wrap_Pos *w) -{ - Scheme_Object *a; - if (w->is_limb && (w->pos + 1 < ((Wrap_Chunk *)SCHEME_CAR(w->l))->len)) { - a = SCHEME_CAR(w->l); - w->pos++; - w->a = ((Wrap_Chunk *)a)->a[w->pos]; - } else { - w->l = SCHEME_CDR(w->l); - if (!SCHEME_NULLP(w->l)) { - a = SCHEME_CAR(w->l); - if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { - w->is_limb = 1; - w->pos = 0; - w->a = ((Wrap_Chunk *)a)->a[0]; - } else { - w->is_limb = 0; - w->a = a; - } - } else - w->is_limb = 0; - } -} - -#define WRAP_POS Wrap_Pos -#define WRAP_POS_INIT(w, wr) w.l = wr; WRAP_POS_SET_FIRST(&w) - -#define WRAP_POS_INC(w) DO_WRAP_POS_INC(&w) - -#define WRAP_POS_INIT_END(w) (w.l = scheme_null, w.a = NULL, w.is_limb = 0, w.pos = 0) -#define WRAP_POS_END_P(w) SCHEME_NULLP(w.l) -#define WRAP_POS_FIRST(w) w.a -#define WRAP_POS_COPY(w, w2) w.l = (w2).l; w.a = (w2).a; w.is_limb= (w2).is_limb; w.pos = (w2).pos - -/* Walking backwards through one chunk: */ - -XFORM_NONGCING static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k) -{ - Scheme_Object *a; - a = SCHEME_CAR(k); - if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { - w->is_limb = 1; - w->l = k; - w->pos = ((Wrap_Chunk *)a)->len - 1; - w->a = ((Wrap_Chunk *)a)->a[w->pos]; - } else { - w->l = k; - w->a = a; - w->is_limb = 0; - w->pos = 0; - } -} - -#define WRAP_POS_KEY(w) w.l -#define WRAP_POS_REVINIT(w, k) DO_WRAP_POS_REVINIT(&w, k) -#define WRAP_POS_REVEND_P(w) (w.pos < 0) -#define WRAP_POS_DEC(w) --w.pos; if (w.pos >= 0) w.a = ((Wrap_Chunk *)SCHEME_CAR(w.l))->a[w.pos] - -#define WRAP_POS_PLAIN_TAIL(w) (w.is_limb ? (w.pos ? NULL : w.l) : w.l) - -/*========================================================================*/ -/* initialization */ -/*========================================================================*/ - -void scheme_init_stx(Scheme_Env *env) -{ -#ifdef MZ_PRECISE_GC - register_traversers(); -#endif - - GLOBAL_FOLDING_PRIM_UNARY_INLINED("syntax?", syntax_p, 1, 1, 1, env); - - GLOBAL_FOLDING_PRIM("syntax->datum", syntax_to_datum, 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("datum->syntax", datum_to_syntax, 2, 5, 1, env); - - GLOBAL_FOLDING_PRIM_UNARY_INLINED("syntax-e", scheme_checked_syntax_e, 1, 1, 1, env); - - GLOBAL_FOLDING_PRIM("syntax-line" , syntax_line , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-column" , syntax_col , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-position", syntax_pos , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-span" , syntax_span , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax-source" , syntax_src , 1, 1, 1, env); - GLOBAL_FOLDING_PRIM("syntax->list" , syntax_to_list, 1, 1, 1, env); - - - GLOBAL_IMMED_PRIM("syntax-original?" , syntax_original_p , 1, 1, env); - GLOBAL_IMMED_PRIM("syntax-property" , syntax_property , 2, 3, env); - GLOBAL_IMMED_PRIM("syntax-property-symbol-keys" , syntax_property_keys , 1, 1, env); - - GLOBAL_IMMED_PRIM("syntax-track-origin" , syntax_track_origin , 3, 3, env); - - GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env); - - GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 3, env); - GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 3, env); - GLOBAL_IMMED_PRIM("free-transformer-identifier=?" , module_trans_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-template-identifier=?" , module_templ_eq , 2, 2, env); - GLOBAL_IMMED_PRIM("free-label-identifier=?" , module_label_eq , 2, 2, env); - - GLOBAL_IMMED_PRIM("identifier-binding" , module_binding , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-transformer-binding" , module_trans_binding , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-template-binding" , module_templ_binding , 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-label-binding" , module_label_binding , 1, 1, env); - GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env); - GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env); - - - GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env); - GLOBAL_IMMED_PRIM("syntax-recertify" , syntax_recertify , 4, 4, env); - - REGISTER_SO(source_symbol); - REGISTER_SO(share_symbol); - REGISTER_SO(origin_symbol); - REGISTER_SO(lexical_symbol); - REGISTER_SO(protected_symbol); - REGISTER_SO(nominal_id_symbol); - source_symbol = scheme_make_symbol("source"); /* not interned! */ - share_symbol = scheme_make_symbol("share"); /* not interned! */ - origin_symbol = scheme_intern_symbol("origin"); - lexical_symbol = scheme_intern_symbol("lexical"); - protected_symbol = scheme_intern_symbol("protected"); - nominal_id_symbol = scheme_intern_symbol("nominal-id"); - - REGISTER_SO(mark_id); - REGISTER_SO(current_rib_timestamp); - mark_id = scheme_make_integer(0); - current_rib_timestamp = scheme_make_integer(0); - - REGISTER_SO(empty_srcloc); - empty_srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); -#ifdef MZTAG_REQUIRED - empty_srcloc->type = scheme_rt_srcloc; -#endif - empty_srcloc->src = scheme_false; - empty_srcloc->line = -1; - empty_srcloc->col = -1; - empty_srcloc->pos = -1; - - REGISTER_SO(empty_simplified); - empty_simplified = scheme_make_vector(2, scheme_false); - - REGISTER_SO(no_nested_inactive_certs); - REGISTER_SO(no_nested_active_certs); - REGISTER_SO(no_nested_certs); - no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL); - no_nested_active_certs = scheme_make_raw_pair(NULL, NULL); - no_nested_certs = scheme_make_raw_pair(NULL, NULL); - SCHEME_SET_NO_INACTIVE_SUBS(no_nested_inactive_certs); - SCHEME_SET_NO_ACTIVE_SUBS(no_nested_active_certs); - SCHEME_SET_NO_INACTIVE_SUBS(no_nested_certs); - SCHEME_SET_NO_ACTIVE_SUBS(no_nested_certs); - - scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); - scheme_install_type_reader2(scheme_free_id_info_type, read_free_id_info_prefix); -} - -void scheme_init_stx_places(int initial_main_os_thread) { - REGISTER_SO(last_phase_shift); - REGISTER_SO(nominal_ipair_cache); - REGISTER_SO(quick_hash_table); - REGISTER_SO(id_marks_ht); - REGISTER_SO(than_id_marks_ht); - REGISTER_SO(interned_skip_ribs); - REGISTER_SO(unsealed_dependencies); - - if (!initial_main_os_thread) { - REGISTER_SO(mark_id); - REGISTER_SO(current_rib_timestamp); - mark_id = scheme_make_integer(0); - current_rib_timestamp = scheme_make_integer(0); - } - - interned_skip_ribs = scheme_make_weak_equal_table(); -} - -/*========================================================================*/ -/* stx creation and maintenance */ -/*========================================================================*/ - -Scheme_Object *scheme_make_stx(Scheme_Object *val, - Scheme_Stx_Srcloc *srcloc, - Scheme_Object *props) -{ - Scheme_Stx *stx; - - stx = MALLOC_ONE_TAGGED(Scheme_Stx); - stx->iso.so.type = scheme_stx_type; - STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0; - stx->val = val; - stx->srcloc = srcloc; - stx->wraps = scheme_null; - stx->props = props; - - return (Scheme_Object *)stx; -} - -Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, - intptr_t line, intptr_t col, intptr_t pos, intptr_t span, - Scheme_Object *src, - Scheme_Object *props) -{ - Scheme_Stx_Srcloc *srcloc; - - srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); -#ifdef MZTAG_REQUIRED - srcloc->type = scheme_rt_srcloc; -#endif - srcloc->src = src; - srcloc->line = line; - srcloc->col = col; - srcloc->pos = pos; - srcloc->span = span; - - return scheme_make_stx(val, srcloc, props); -} - -Scheme_Object *scheme_make_renamed_stx(Scheme_Object *sym, - Scheme_Object *rn) -{ - Scheme_Object *stx; - - stx = scheme_make_stx(sym, empty_srcloc, NULL); - - if (rn) { - rn = scheme_make_pair(rn, scheme_null); - ((Scheme_Stx *)stx)->wraps = rn; - } - - return stx; -} - -Scheme_Object *scheme_stx_track(Scheme_Object *naya, - Scheme_Object *old, - Scheme_Object *origin) - /* Maintain properties for an expanded expression */ -{ - Scheme_Stx *nstx = (Scheme_Stx *)naya; - Scheme_Stx *ostx = (Scheme_Stx *)old; - Scheme_Object *ne, *oe, *e1, *e2; - Scheme_Object *certs; - Scheme_Object *wraps, *modinfo_cache; - intptr_t lazy_prefix; - - if (nstx->props) { - if (SAME_OBJ(nstx->props, STX_SRCTAG)) { - /* Retain 'source tag. */ - ne = ICONS(ICONS(source_symbol, scheme_true), scheme_null); - } else - ne = nstx->props; - } else - ne = scheme_null; - - if (ostx->props) { - if (SAME_OBJ(ostx->props, STX_SRCTAG)) { - /* Drop 'source, add 'origin. */ - oe = NULL; - } else { - Scheme_Object *p, *a; - int mod = 0, add = 1; - - oe = ostx->props; - - /* Drop 'source and 'share, add 'origin if not there */ - for (p = oe; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) { - a = SCHEME_CAR(SCHEME_CAR(p)); - if (SAME_OBJ(a, source_symbol) || SAME_OBJ(a, share_symbol)) - mod = 1; - else if (SAME_OBJ(a, origin_symbol)) - mod = 1; - } - - if (mod) { - Scheme_Object *first = scheme_null, *last = NULL; - - for (; SCHEME_PAIRP(oe); oe = SCHEME_CDR(oe)) { - a = SCHEME_CAR(SCHEME_CAR(oe)); - if (!SAME_OBJ(a, source_symbol) && !SAME_OBJ(a, share_symbol)) { - if (!SAME_OBJ(a, origin_symbol)) { - p = ICONS(SCHEME_CAR(oe), scheme_null); - } else { - p = ICONS(ICONS(a, ICONS(origin, - SCHEME_CDR(SCHEME_CAR(oe)))), - scheme_null); - add = 0; - } - - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - } - - oe = first; - } - if (add) { - oe = ICONS(ICONS(origin_symbol, - ICONS(origin, scheme_null)), - oe); - } - } - } else { - /* Add 'origin. */ - oe = NULL; - } - - if (!oe) - oe = ICONS(ICONS(origin_symbol, - ICONS(origin, scheme_null)), - scheme_null); - - /* Merge ne and oe (ne takes precedence). */ - - /* First, check for overlap: */ - for (e1 = ne; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) { - Scheme_Object *a; - a = SCHEME_CAR(SCHEME_CAR(e1)); - for (e2 = oe; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) { - if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) { - break; - } - } - if (!SCHEME_NULLP(e1)) - break; - } - - if (SCHEME_NULLP(e1)) { - /* Can just append props info (probably the common case). */ - if (!SCHEME_NULLP(oe)) - ne = scheme_append(ne, oe); - } else { - /* Have to perform an actual merge: */ - Scheme_Object *first = scheme_null, *last = NULL, *p; - - for (e1 = ne; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) { - Scheme_Object *a, *v; - a = SCHEME_CAR(SCHEME_CAR(e1)); - v = SCHEME_CDR(SCHEME_CAR(e1)); - for (e2 = oe; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) { - if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) { - v = ICONS(v, SCHEME_CDR(SCHEME_CAR(e2))); - break; - } - } - - p = ICONS(ICONS(a, v), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - for (e1 = oe; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) { - Scheme_Object *a, *v; - a = SCHEME_CAR(SCHEME_CAR(e1)); - v = SCHEME_CDR(SCHEME_CAR(e1)); - for (e2 = ne; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) { - if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) { - v = NULL; - break; - } - } - - if (v) { - p = ICONS(ICONS(a, v), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - } - - ne = first; - } - - /* Clone nstx, keeping wraps, changing props to ne */ - - wraps = nstx->wraps; - if (STX_KEY(nstx) & STX_SUBSTX_FLAG) { - modinfo_cache = NULL; - lazy_prefix = nstx->u.lazy_prefix; - } else { - modinfo_cache = nstx->u.modinfo_cache; - lazy_prefix = 0; - } - - certs = nstx->certs; - - nstx = (Scheme_Stx *)scheme_make_stx(nstx->val, nstx->srcloc, ne); - - nstx->wraps = wraps; - if (modinfo_cache) - nstx->u.modinfo_cache = modinfo_cache; - else - nstx->u.lazy_prefix = lazy_prefix; - - nstx->certs = certs; - - return (Scheme_Object *)nstx; -} - -/******************** chain cache ********************/ - -static int maybe_add_chain_cache(Scheme_Stx *stx) -{ - WRAP_POS awl; - Scheme_Object *p; - int skipable = 0, pos = 1; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - - while (!WRAP_POS_END_P(awl)) { - /* Skip over renames, cancelled marks, and negative marks: */ - p = WRAP_POS_FIRST(awl); - if (SCHEME_VECTORP(p)) { - skipable++; - } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { - /* ok to skip, but don<'t count toward needing a cache */ - } else if (SCHEME_HASHTP(p)) { - /* Hack: we store the depth of the table in the chain - in the `size' fields, at least until the table is initialized: */ - Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p; - if (!ht2->count) - pos = ht2->size; - else { - p = scheme_hash_get(ht2, scheme_make_integer(2)); - pos = SCHEME_INT_VAL(p); - } - pos++; - break; - } else - break; - WRAP_POS_INC(awl); - } - - if (skipable >= 32) { - /* Insert a cache placeholder. We'll fill it if - it's ever used in resolve_env(). */ - Scheme_Hash_Table *ht; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - - ht->size = pos; - - p = scheme_make_pair((Scheme_Object *)ht, stx->wraps); - stx->wraps = p; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - stx->u.lazy_prefix++; - - return 1; - } - - return 0; -} - -static void set_wraps_to_skip(Scheme_Hash_Table *ht, WRAP_POS *wraps) -{ - Scheme_Object *v; - - v = scheme_hash_get(ht, scheme_make_integer(0)); - wraps->l = v; - v = scheme_hash_get(ht, scheme_make_integer(1)); - if (SCHEME_TRUEP(v)) { - wraps->pos = SCHEME_INT_VAL(v); - wraps->is_limb = 1; - wraps->a = ((Wrap_Chunk *)SCHEME_CAR(wraps->l))->a[wraps->pos]; - } else { - wraps->is_limb = 0; - if (!SCHEME_NULLP(wraps->l)) - wraps->a = SCHEME_CAR(wraps->l); - } -} - -static void fill_chain_cache(Scheme_Object *wraps) -{ - int pos, max_depth, limit; - Scheme_Hash_Table *ht; - Scheme_Object *p, *id; - WRAP_POS awl; - - ht = (Scheme_Hash_Table *)SCHEME_CAR(wraps); - - p = scheme_hash_get(ht, scheme_make_integer(5)); - if (p) { - limit = SCHEME_INT_VAL(p); - - /* Extend the chain cache to deeper: */ - set_wraps_to_skip(ht, &awl); - - p = scheme_hash_get(ht, scheme_make_integer(2)); - pos = SCHEME_INT_VAL(p); - - scheme_hash_set(ht, scheme_make_integer(5), NULL); - } else { - pos = ht->size; - ht->size = 0; - - wraps = SCHEME_CDR(wraps); - - WRAP_POS_INIT(awl, wraps); - - limit = 4; - } - - /* Limit how much of the cache we build, in case we never - reuse this cache: */ - max_depth = limit; - - while (!WRAP_POS_END_P(awl)) { - if (!(max_depth--)) { - limit *= 2; - scheme_hash_set(ht, scheme_make_integer(5), scheme_make_integer(limit)); - break; - } - - p = WRAP_POS_FIRST(awl); - if (SCHEME_VECTORP(p)) { - int i, len; - len = SCHEME_RENAME_LEN(p); - for (i = 0; i < len; i++) { - id = SCHEME_VEC_ELS(p)[i+2]; - if (SCHEME_STXP(id)) - id = SCHEME_STX_VAL(id); - scheme_hash_set(ht, id, scheme_true); - } - } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { - /* ok to skip */ - } else if (SCHEME_HASHTP(p)) { - /* Hack: we store the depth of the table in the chain - in the `size' fields, at least until the table is initialized: */ - Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p; - int pos2; - if (!ht2->count) - pos2 = ht2->size; - else { - p = scheme_hash_get(ht2, scheme_make_integer(2)); - pos2 = SCHEME_INT_VAL(p); - } - /* The theory here is the same as the `mapped' table: - every power of two covers the whole range, etc. */ - if ((pos & pos2) == pos2) - break; - } else - break; - WRAP_POS_INC(awl); - } - - /* Record skip destination: */ - scheme_hash_set(ht, scheme_make_integer(0), awl.l); - if (!awl.is_limb) { - scheme_hash_set(ht, scheme_make_integer(1), scheme_false); - } else { - scheme_hash_set(ht, scheme_make_integer(1), scheme_make_integer(awl.pos)); - } - scheme_hash_set(ht, scheme_make_integer(2), scheme_make_integer(pos)); -} - -/******************** marks ********************/ - -Scheme_Object *scheme_new_mark() -{ - mark_id = scheme_add1(1, &mark_id); - return mark_id; -} - -static Scheme_Object *negate_mark(Scheme_Object *n) -{ - return scheme_bin_minus(scheme_make_integer(0), n); -} - -Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *wraps; - Scheme_Object *certs; - intptr_t lp; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - lp = stx->u.lazy_prefix; - else - lp = 1; - - wraps = stx->wraps; - if (SCHEME_PAIRP(wraps) - && SAME_OBJ(m, SCHEME_CAR(wraps)) - && lp) { - --lp; - wraps = SCHEME_CDR(wraps); - } else { - if (maybe_add_chain_cache(stx)) - lp++; - wraps = stx->wraps; - lp++; - wraps = CONS(m, wraps); - } - - certs = stx->certs; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = wraps; - stx->certs = certs; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - stx->u.lazy_prefix = lp; - /* else cache should stay zeroed */ - - return (Scheme_Object *)stx; -} - -/******************** lexical renames ********************/ - -#define RENAME_HT_THRESHOLD 15 - -Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) -{ - Scheme_Object *v; - int i; - - v = scheme_make_vector((2 * c) + 2, NULL); - SCHEME_VEC_ELS(v)[0] = newname; - if (c > RENAME_HT_THRESHOLD) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; - } else - SCHEME_VEC_ELS(v)[1] = scheme_false; - - for (i = 0; i < c; i++) { - SCHEME_VEC_ELS(v)[2 + c + i] = scheme_void; - } - - return v; -} - -static void maybe_install_rename_hash_table(Scheme_Object *v) -{ - if (SCHEME_VEC_SIZE(v) > ((2 * RENAME_HT_THRESHOLD) + 2)) { - Scheme_Hash_Table *ht; - int i; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; - for (i = (SCHEME_VEC_SIZE(v) - 2) >> 1; i--; ) { - scheme_hash_set(ht, SCHEME_VEC_ELS(v)[i + 2], scheme_make_integer(i)); - } - SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; - } -} - -void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname) -{ - /* Every added name must be symbolicly distinct! */ - - SCHEME_VEC_ELS(rnm)[2 + pos] = oldname; - - /* Add ht mapping, if there's a hash table: */ - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rnm)[1])) { - Scheme_Hash_Table *ht; - ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(rnm)[1]; - if (scheme_hash_get(ht, SCHEME_STX_VAL(oldname))) - pos = -1; /* -1 means multiple entries matching a name */ - scheme_hash_set(ht, SCHEME_STX_VAL(oldname), scheme_make_integer(pos)); - } -} - -Scheme_Object *scheme_make_rename_rib() -{ - Scheme_Lexical_Rib *rib; - int *sealed; - - rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); - rib->so.type = scheme_lexical_rib_type; - rib->timestamp = current_rib_timestamp; - - sealed = (int *)scheme_malloc_atomic(sizeof(int)); - *sealed = 0; - rib->sealed = sealed; - - current_rib_timestamp = scheme_add1(1, ¤t_rib_timestamp); - - return (Scheme_Object *)rib; -} - -void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) -{ - Scheme_Lexical_Rib *rib, *naya; - Scheme_Object *next; - Scheme_Hash_Table *mapped_names; - int i; - - naya = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); - naya->so.type = scheme_lexical_rib_type; - naya->rename = rename; - - rib = (Scheme_Lexical_Rib *)ro; - naya->next = rib->next; - rib->next = naya; - - naya->timestamp = rib->timestamp; - naya->sealed = rib->sealed; - - while (unsealed_dependencies) { - next = SCHEME_CDR(unsealed_dependencies); - SCHEME_CAR(unsealed_dependencies) = NULL; - SCHEME_CDR(unsealed_dependencies) = NULL; - unsealed_dependencies = next; - } - - if (!rib->mapped_names) - rib->mapped_names = scheme_make_integer(1); - else if (SCHEME_INTP(rib->mapped_names)) { - rib->mapped_names = scheme_make_integer(SCHEME_INT_VAL(rib->mapped_names) + 1); - if (SCHEME_INT_VAL(rib->mapped_names) > 32) { - /* Build the initial table */ - mapped_names = scheme_make_hash_table(SCHEME_hash_ptr); - while (naya) { - for (i = SCHEME_RENAME_LEN(naya->rename); i--; ) { - scheme_hash_set(mapped_names, - SCHEME_STX_SYM(SCHEME_VEC_ELS(naya->rename)[2+i]), - scheme_true); - } - naya = naya->next; - } - rib->mapped_names = (Scheme_Object *)mapped_names; - } - } else { - for (i = SCHEME_RENAME_LEN(naya->rename); i--; ) { - scheme_hash_set((Scheme_Hash_Table *)rib->mapped_names, - SCHEME_STX_SYM(SCHEME_VEC_ELS(naya->rename)[2+i]), - scheme_true); - } - } -} - -void scheme_drop_first_rib_rename(Scheme_Object *ro) -{ - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro; - rib->next = rib->next->next; -} - -void scheme_stx_seal_rib(Scheme_Object *rib) -{ - *((Scheme_Lexical_Rib *)rib)->sealed = 1; -} - -int *scheme_stx_get_rib_sealed(Scheme_Object *rib) -{ - return ((Scheme_Lexical_Rib *)rib)->sealed; -} - -Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro) -{ - Scheme_Object *v; - int count = 0, rib_count = 0; - WRAP_POS awl; - Wrap_Chunk *wc; - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro, *rib2; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(awl)) { - count++; - v = WRAP_POS_FIRST(awl); - if (SCHEME_RIBP(v)) { - rib2 = (Scheme_Lexical_Rib *)v; - if (SAME_OBJ(rib2->timestamp, rib->timestamp)) - rib_count++; - } - WRAP_POS_INC(awl); - } - - if (!rib_count) - return stx; - - count -= rib_count; - - wc = MALLOC_WRAP_CHUNK(count); - wc->type = scheme_wrap_chunk_type; - wc->len = count; - - count = 0; - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (SCHEME_RIBP(v)) { - rib2 = (Scheme_Lexical_Rib *)v; - if (SAME_OBJ(rib2->timestamp, rib->timestamp)) - v = NULL; - } - if (v) { - wc->a[count++] = v; - } - WRAP_POS_INC(awl); - } - - v = scheme_make_pair((Scheme_Object *)wc, scheme_null); - - stx = scheme_add_rename(stx, scheme_make_integer(0)); - ((Scheme_Stx *)stx)->wraps = v; - - return stx; -} - -static Scheme_Object *make_prune_context(Scheme_Object *a) -{ - Scheme_Object *p; - - p = scheme_alloc_small_object(); - p->type = scheme_prune_context_type; - SCHEME_BOX_VAL(p) = a; - - return p; -} - -/******************** module renames ********************/ - -static int same_phase(Scheme_Object *a, Scheme_Object *b) -{ - if (SAME_OBJ(a, b)) - return 1; - else if (SCHEME_INTP(a) || SCHEME_INTP(b) - || SCHEME_FALSEP(a) || SCHEME_FALSEP(b)) - return 0; - else - return scheme_eqv(a, b); -} - -Scheme_Object *scheme_make_module_rename_set(int kind, Scheme_Object *share_marked_names) -{ - Module_Renames_Set *mrns; - Scheme_Object *mk; - - if (share_marked_names) - mk = ((Module_Renames_Set *)share_marked_names)->set_identity; - else - mk = scheme_new_mark(); - - mrns = MALLOC_ONE_TAGGED(Module_Renames_Set); - mrns->so.type = scheme_rename_table_set_type; - mrns->kind = kind; - mrns->share_marked_names = share_marked_names; - mrns->set_identity = mk; - - return (Scheme_Object *)mrns; -} - -void scheme_add_module_rename_to_set(Scheme_Object *set, Scheme_Object *rn) -{ - Module_Renames_Set *mrns = (Module_Renames_Set *)set; - Module_Renames *mrn = (Module_Renames *)rn; - - mrn->set_identity = mrns->set_identity; - - if (same_phase(mrn->phase, scheme_make_integer(0))) - mrns->rt = mrn; - else if (same_phase(mrn->phase, scheme_make_integer(1))) - mrns->et = mrn; - else { - Scheme_Hash_Table *ht; - ht = mrns->other_phases; - if (!ht) { - ht = scheme_make_hash_table_equal(); - mrns->other_phases = ht; - } - scheme_hash_set(ht, mrn->phase, (Scheme_Object *)mrn); - } -} - -Scheme_Object *scheme_get_module_rename_from_set(Scheme_Object *set, Scheme_Object *phase, int create) -{ - Module_Renames_Set *mrns = (Module_Renames_Set *)set; - Module_Renames *mrn; - - if (same_phase(phase, scheme_make_integer(0))) - mrn = mrns->rt; - else if (same_phase(phase, scheme_make_integer(1))) - mrn = mrns->et; - else if (mrns->other_phases) - mrn = (Module_Renames *)scheme_hash_get(mrns->other_phases, phase); - else - mrn = NULL; - - if (!mrn && create) { - Scheme_Hash_Table *marked_names; - - if (mrns->share_marked_names) - marked_names = scheme_get_module_rename_marked_names(mrns->share_marked_names, phase, 1); - else - marked_names = NULL; - - mrn = (Module_Renames *)scheme_make_module_rename(phase, mrns->kind, marked_names); - - scheme_add_module_rename_to_set(set, (Scheme_Object *)mrn); - } - - return (Scheme_Object *)mrn; -} - -Scheme_Hash_Table *scheme_get_module_rename_marked_names(Scheme_Object *set, Scheme_Object *phase, int create) -{ - Scheme_Object *rn; - - rn = scheme_get_module_rename_from_set(set, phase, create); - if (!rn) - return NULL; - - if (((Module_Renames *)rn)->marked_names) - return ((Module_Renames *)rn)->marked_names; - - if (create) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ((Module_Renames *)rn)->marked_names = ht; - return ht; - } - - return NULL; -} - -Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *marked_names) -{ - Module_Renames *mr; - Scheme_Hash_Table *ht; - Scheme_Object *mk; - - mk = scheme_new_mark(); - - mr = MALLOC_ONE_TAGGED(Module_Renames); - mr->so.type = scheme_rename_table_type; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - - mr->ht = ht; - mr->phase = phase; - mr->kind = kind; - mr->set_identity = mk; - mr->marked_names = marked_names; - mr->shared_pes = scheme_null; - mr->unmarshal_info = scheme_null; - - return (Scheme_Object *)mr; -} - -void scheme_seal_module_rename(Scheme_Object *rn, int level) -{ - ((Module_Renames *)rn)->sealed = level; -} - -void scheme_seal_module_rename_set(Scheme_Object *_rns, int level) -{ - Module_Renames_Set *rns = (Module_Renames_Set *)_rns; - - rns->sealed = level; - if (rns->rt) - rns->rt->sealed = level; - if (rns->et) - rns->et->sealed = level; - if (rns->other_phases) { - int i; - for (i = 0; i < rns->other_phases->size; i++) { - if (rns->other_phases->vals[i]) { - ((Module_Renames *)rns->other_phases->vals[i])->sealed = level; - } - } - } -} - -static void check_not_sealed(Module_Renames *mrn) -{ - if (mrn->sealed >= STX_SEAL_ALL) - scheme_signal_error("internal error: attempt to change sealed module rename"); -} - -static Scheme_Object *phase_to_index(Scheme_Object *phase) -{ - return phase; -} - -Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, - Scheme_Object *modname, /* actual source module */ - Scheme_Object *localname, /* name in local context */ - Scheme_Object *exname, /* name in definition context */ - Scheme_Object *nominal_mod, /* nominal source module */ - Scheme_Object *nominal_ex, /* nominal import before local renaming */ - intptr_t mod_phase, /* phase of source defn */ - Scheme_Object *src_phase_index, /* nominal import phase */ - Scheme_Object *nom_phase, /* nominal export phase */ - Scheme_Object *insp, /* inspector for re-export */ - int mode) /* 1 => can be reconstructed from unmarshal info - 2 => free-id=? renaming - 3 => return info */ -{ - Scheme_Object *elem; - Scheme_Object *phase_index; - - if (mode != 3) - check_not_sealed((Module_Renames *)mrn); - - phase_index = phase_to_index(((Module_Renames *)mrn)->phase); - if (!src_phase_index) - src_phase_index = phase_index; - if (!nom_phase) - nom_phase = scheme_make_integer(mod_phase); - - if (SAME_OBJ(modname, nominal_mod) - && SAME_OBJ(exname, nominal_ex) - && !mod_phase - && same_phase(src_phase_index, phase_index) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (SAME_OBJ(localname, exname)) - elem = modname; - else - elem = CONS(modname, exname); - } else if (SAME_OBJ(exname, nominal_ex) - && SAME_OBJ(localname, exname) - && !mod_phase - && same_phase(src_phase_index, phase_index) - && same_phase(nom_phase, scheme_make_integer(mod_phase))) { - /* It's common that a sequence of similar mappings shows up, - e.g., '(#%kernel . mzscheme) */ - if (nominal_ipair_cache - && SAME_OBJ(SCHEME_CAR(nominal_ipair_cache), modname) - && SAME_OBJ(SCHEME_CDR(nominal_ipair_cache), nominal_mod)) - elem = nominal_ipair_cache; - else { - elem = ICONS(modname, nominal_mod); - nominal_ipair_cache = elem; - } - } else { - if (same_phase(nom_phase, scheme_make_integer(mod_phase))) { - if (same_phase(src_phase_index, phase_index)) - elem = nominal_mod; - else - elem = CONS(nominal_mod, src_phase_index); - } else { - elem = CONS(nominal_mod, CONS(src_phase_index, nom_phase)); - } - elem = CONS(exname, CONS(elem, nominal_ex)); - if (mod_phase) - elem = CONS(scheme_make_integer(mod_phase), elem); - elem = CONS(modname, elem); - } - - if (insp) - elem = CONS(insp, elem); - - if (mode == 1) { - if (!((Module_Renames *)mrn)->nomarshal_ht) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ((Module_Renames *)mrn)->nomarshal_ht = ht; - } - scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, elem); - } else if (mode == 2) { - scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, elem); - } else if (mode == 3) { - return elem; - } else - scheme_hash_set(((Module_Renames *)mrn)->ht, localname, elem); - - return NULL; -} - -void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, - Scheme_Module_Phase_Exports *pt, - Scheme_Object *unmarshal_phase_index, - Scheme_Object *src_phase_index, - Scheme_Object *marks, - int save_unmarshal) -{ - Module_Renames *mrn = (Module_Renames *)rn; - Scheme_Object *pr, *index_plus_marks; - - check_not_sealed(mrn); - - if (SCHEME_PAIRP(marks)) - index_plus_marks = scheme_make_pair(marks, src_phase_index); - else - index_plus_marks = src_phase_index; - - pr = scheme_make_pair(scheme_make_pair(modidx, - scheme_make_pair((Scheme_Object *)pt, - index_plus_marks)), - mrn->shared_pes); - mrn->shared_pes = pr; - - if (save_unmarshal) { - pr = scheme_make_pair(scheme_make_pair(modidx, - scheme_make_pair(unmarshal_phase_index, - index_plus_marks)), - mrn->unmarshal_info); - mrn->unmarshal_info = pr; - } -} - -void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info) -{ - Scheme_Object *l; - - l = scheme_make_pair(info, ((Module_Renames *)rn)->unmarshal_info); - ((Module_Renames *)rn)->unmarshal_info = l; -} - -static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, - Scheme_Object *old_midx, Scheme_Object *new_midx, - int do_pes, int do_unm, - Scheme_Object *new_insp) -{ - Scheme_Hash_Table *ht, *hts, *drop_ht; - Scheme_Object *v; - int i, t; - - check_not_sealed((Module_Renames *)dest); - - if (do_pes) { - if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) { - Scheme_Object *first = NULL, *last = NULL, *pr, *l; - for (l = ((Module_Renames *)src)->shared_pes; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - pr = scheme_make_pair(SCHEME_CAR(l), scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - } - SCHEME_CDR(last) = ((Module_Renames *)dest)->shared_pes; - ((Module_Renames *)dest)->shared_pes = first; - } - } - - if (do_unm) { - if (!SCHEME_NULLP(((Module_Renames *)src)->unmarshal_info)) { - Scheme_Object *first = NULL, *last = NULL, *pr, *l; - for (l = ((Module_Renames *)src)->unmarshal_info; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - pr = scheme_make_pair(SCHEME_CAR(l), scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - } - SCHEME_CDR(last) = ((Module_Renames *)dest)->unmarshal_info; - ((Module_Renames *)dest)->unmarshal_info = first; - - ((Module_Renames *)dest)->needs_unmarshal = 1; - } - } - - for (t = 0; t < 2; t++) { - if (!t) { - ht = ((Module_Renames *)dest)->ht; - hts = ((Module_Renames *)src)->ht; - drop_ht = ((Module_Renames *)dest)->nomarshal_ht; - } else { - hts = ((Module_Renames *)src)->nomarshal_ht; - if (!hts) - break; - ht = ((Module_Renames *)dest)->nomarshal_ht; - if (!ht) { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - ((Module_Renames *)dest)->nomarshal_ht = ht; - } - drop_ht = ((Module_Renames *)dest)->ht; - } - - /* Mappings in src overwrite mappings in dest: */ - - for (i = hts->size; i--; ) { - if (hts->vals[i]) { - v = hts->vals[i]; - if (old_midx) { - Scheme_Object *insp = NULL; - - if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) { - insp = SCHEME_CAR(v); - if (new_insp) insp = new_insp; - v = SCHEME_CDR(v); - } else - insp = NULL; - - /* Shift the modidx part */ - if (SCHEME_PAIRP(v)) { - if (SCHEME_PAIRP(SCHEME_CDR(v))) { - /* (list* modidx [mod-phase] exportname nominal_modidx+index nominal_exportname) */ - Scheme_Object *midx1, *midx2; - intptr_t mod_phase; - midx1 = SCHEME_CAR(v); - v = SCHEME_CDR(v); - if (SCHEME_INTP(SCHEME_CAR(v))) { - mod_phase = SCHEME_INT_VAL(SCHEME_CAR(v)); - v = SCHEME_CDR(v); - } else - mod_phase = 0; - midx2 = SCHEME_CAR(SCHEME_CDR(v)); - midx1 = scheme_modidx_shift(midx1, old_midx, new_midx); - if (SCHEME_PAIRP(midx2)) { - midx2 = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(midx2), old_midx, new_midx), - SCHEME_CDR(midx2)); - } else { - midx2 = scheme_modidx_shift(midx2, old_midx, new_midx); - } - v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v)))); - if (mod_phase) - v = CONS(scheme_make_integer(mod_phase), v); - v = CONS(midx1, v); - } else if (nom_mod_p(v)) { - /* (cons modidx nominal_modidx) */ - v = ICONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx), - scheme_modidx_shift(SCHEME_CDR(v), old_midx, new_midx)); - } else { - /* (cons modidx exportname) */ - v = CONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx), - SCHEME_CDR(v)); - } - } else { - /* modidx */ - v = scheme_modidx_shift(v, old_midx, new_midx); - } - - if (insp) - v = CONS(insp, v); - } - scheme_hash_set(ht, hts->keys[i], v); - if (drop_ht) - scheme_hash_set(drop_ht, hts->keys[i], NULL); - } - } - } - - /* Need to share marked names: */ - - if (((Module_Renames *)src)->marked_names) { - ((Module_Renames *)dest)->marked_names = ((Module_Renames *)src)->marked_names; - } -} - -void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest, int do_unm) -{ - do_append_module_rename(src, dest, NULL, NULL, 1, do_unm, NULL); -} - -void scheme_append_rename_set_to_env(Scheme_Object *_mrns, Scheme_Env *env) -{ - Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns; - Scheme_Object *mrns2; - int i; - - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - mrns2 = env->rename_set; - - if (mrns->rt) { - scheme_append_module_rename((Scheme_Object *)mrns->rt, - scheme_get_module_rename_from_set(mrns2, scheme_make_integer(0), 1), - 1); - } - if (mrns->et) { - scheme_append_module_rename((Scheme_Object *)mrns->et, - scheme_get_module_rename_from_set(mrns2, scheme_make_integer(1), 1), - 1); - } - if (mrns->other_phases) { - for (i = 0; i < mrns->other_phases->size; i++) { - if (mrns->other_phases->vals[i]) { - scheme_append_module_rename(mrns->other_phases->vals[i], - scheme_get_module_rename_from_set(mrns2, - mrns->other_phases->keys[i], - 1), - 1); - } - } - } -} - -void scheme_remove_module_rename(Scheme_Object *mrn, - Scheme_Object *localname) -{ - check_not_sealed((Module_Renames *)mrn); - scheme_hash_set(((Module_Renames *)mrn)->ht, localname, NULL); - if (((Module_Renames *)mrn)->nomarshal_ht) - scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, NULL); - if (((Module_Renames *)mrn)->free_id_renames) - scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, NULL); -} - -void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht, - Scheme_Hash_Table *export_registry) -{ - /* Put every name mapped by src into ht: */ - Scheme_Object *pr; - Scheme_Hash_Table *hts; - int i, t; - Scheme_Module_Phase_Exports *pt; - Module_Renames *src; - - if (SCHEME_RENAMES_SETP(set)) - src = ((Module_Renames_Set *)set)->rt; - else - src = (Module_Renames *)set; - - if (!src) - return; - - if (src->needs_unmarshal) { - unmarshal_rename(src, NULL, NULL, export_registry); - } - - for (t = 0; t < 2; t++) { - if (!t) - hts = src->ht; - else { - hts = src->nomarshal_ht; - } - - if (hts) { - for (i = hts->size; i--; ) { - if (hts->vals[i]) { - scheme_hash_set(ht, hts->keys[i], scheme_false); - } - } - } - } - - for (pr = src->shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { - pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); - for (i = pt->num_provides; i--; ) { - scheme_hash_set(ht, pt->provides[i], scheme_false); - } - } -} - - -Scheme_Object *scheme_rename_to_stx(Scheme_Object *mrn) -{ - Scheme_Object *stx; - stx = scheme_make_stx(scheme_false, empty_srcloc, NULL); - return scheme_add_rename(stx, mrn); -} - -Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx) -{ - Scheme_Object *rns = NULL, *v; - WRAP_POS wl; - - WRAP_POS_INIT(wl, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(wl)) { - v = WRAP_POS_FIRST(wl); - if (SCHEME_RENAMES_SETP(v)) { - if (rns) - scheme_signal_error("can't convert syntax to rename (two sets)"); - rns = v; - } else if (SCHEME_RENAMESP(v)) { - if (!rns) - rns = scheme_make_module_rename_set(((Module_Renames *)v)->kind, NULL); - scheme_add_module_rename_to_set(rns, v); - } else { - scheme_signal_error("can't convert syntax to rename (non-rename in wrap)"); - } - WRAP_POS_INC(wl); - } - - if (!rns) - scheme_signal_error("can't convert syntax to rename (empty)"); - - return rns; -} - -Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Object *new_insp) -{ - Scheme_Object *nmrn, *a, *l, *nl, *first, *last; - - nmrn = scheme_make_module_rename(((Module_Renames *)mrn)->phase, - mzMOD_RENAME_NORMAL, - NULL); - - /* use "append" to copy most info: */ - do_append_module_rename(mrn, nmrn, old_midx, new_midx, 0, 0, new_insp); - - /* Manually copy unmarshal_infos, where we have to shift anyway: */ - - l = ((Module_Renames *)mrn)->unmarshal_info; - first = scheme_null; - last = NULL; - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx), - SCHEME_CDR(a)), - scheme_null); - if (last) - SCHEME_CDR(last) = nl; - else - first = nl; - last = nl; - l = SCHEME_CDR(l); - } - ((Module_Renames *)nmrn)->unmarshal_info = first; - - l = ((Module_Renames *)mrn)->shared_pes; - first = scheme_null; - last = NULL; - while (!SCHEME_NULLP(l)) { - a = SCHEME_CAR(l); - nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx), - SCHEME_CDR(a)), - scheme_null); - if (last) - SCHEME_CDR(last) = nl; - else - first = nl; - last = nl; - l = SCHEME_CDR(l); - } - ((Module_Renames *)nmrn)->shared_pes = first; - - if (((Module_Renames *)mrn)->needs_unmarshal) { - ((Module_Renames *)nmrn)->needs_unmarshal = 1; - } - - return nmrn; -} - -Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Object *new_insp) -{ - Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns; - Scheme_Object *mrn, *mrns2; - int i; - - mrns2 = scheme_make_module_rename_set(mrns->kind, NULL); - if (mrns->rt) { - mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx, new_insp); - scheme_add_module_rename_to_set(mrns2, mrn); - } - if (mrns->et) { - mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->et, old_midx, new_midx, new_insp); - scheme_add_module_rename_to_set(mrns2, mrn); - } - if (mrns->other_phases) { - for (i = 0; i < mrns->other_phases->size; i++) { - if (mrns->other_phases->vals[i]) { - mrn = scheme_stx_shift_rename(mrns->other_phases->vals[i], old_midx, new_midx, new_insp); - scheme_add_module_rename_to_set(mrns2, mrn); - } - } - } - - return (Scheme_Object *)mrns2; -} - - -Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn) -{ - return ((Module_Renames *)rn)->marked_names; -} - -static void unmarshal_rename(Module_Renames *mrn, - Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, - Scheme_Hash_Table *export_registry) -{ - Scheme_Object *l; - int sealed; - - mrn->needs_unmarshal = 0; - - sealed = mrn->sealed; - if (sealed) - mrn->sealed = 0; - - l = scheme_reverse(mrn->unmarshal_info); - for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l), - modidx_shift_from, modidx_shift_to, - export_registry); - } - - if (sealed) - mrn->sealed = sealed; -} - -/******************** wrap manipulations ********************/ - -Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *wraps; - Scheme_Object *certs; - intptr_t lp; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - preemptive_chunk(stx); - - /* relative order matters: chunk first, so that chunking - doesn't immediately throw away a chain cache */ - - maybe_add_chain_cache(stx); - - wraps = CONS(rename, stx->wraps); - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - lp = stx->u.lazy_prefix + 1; - else - lp = 0; - - certs = stx->certs; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = wraps; - stx->certs = certs; - - stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */ - - if (stx->certs) - phase_shift_certs((Scheme_Object *)stx, stx->wraps, 1); - - return (Scheme_Object *)stx; -} - -void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i) -{ - Scheme_Object *stx; - int c; - - stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]), - (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair)); - rp->stxes[i] = stx; - c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair)); - --c; - SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c); - if (!c) { - SCHEME_CDR(rp->delay_info_rpair) = NULL; - rp->delay_info_rpair = NULL; - } -} - -Scheme_Object *scheme_delayed_rename(Scheme_Object **o, intptr_t i) -{ - Scheme_Object *rename; - Resolve_Prefix *rp; - - rename = o[0]; - - if (!rename) return scheme_false; /* happens only with corrupted .zo! */ - - rp = (Resolve_Prefix *)o[1]; - - if (SCHEME_INTP(rp->stxes[i])) - scheme_load_delayed_syntax(rp, i); - - return scheme_add_rename(rp->stxes[i], rename); -} - -Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) -{ -#if 0 - WRAP_POS wl; - - /* Shortcut: there's a good chance that o already has the renaming rib */ - WRAP_POS_INIT(wl, ((Scheme_Stx *)o)->wraps); - if (!WRAP_POS_END_P(wl)) { - if (SAME_OBJ(rib, WRAP_POS_FIRST(wl))) { - return o; - } - } -#endif - - return scheme_add_rename(o, rib); -} - -Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs) -{ - Scheme_Object *s; - - s = scheme_alloc_small_object(); - s->type = scheme_rib_delimiter_type; - SCHEME_BOX_VAL(s) = ribs; - - return scheme_add_rename(o, s); -} - -static int is_in_rib_delim(Scheme_Object *envname, Scheme_Object *rib_delim) -{ - Scheme_Object *l = SCHEME_BOX_VAL(rib_delim); - Scheme_Lexical_Rib *rib; - - while (!SCHEME_NULLP(l)) { - rib = (Scheme_Lexical_Rib *)SCHEME_CAR(l); - while (rib) { - if (rib->rename && SAME_OBJ(envname, SCHEME_VEC_ELS(rib->rename)[0])) - return 1; - rib = rib->next; - } - l = SCHEME_CDR(l); - } - return 0; -} - -static Scheme_Hash_Table *make_recur_table() -{ - if (quick_hash_table) { - GC_CAN_IGNORE Scheme_Hash_Table *t; - t = quick_hash_table; - quick_hash_table = NULL; - return t; - } else - return scheme_make_hash_table(SCHEME_hash_ptr); -} - -static void release_recur_table(Scheme_Hash_Table *free_id_recur) -{ - if (!free_id_recur->size && !quick_hash_table) { - quick_hash_table = free_id_recur; - } -} - -static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, - Scheme_Object *id, - Scheme_Object *orig_id, - int *_sealed, - Scheme_Hash_Table *free_id_recur) -{ - Scheme_Object *result; - Scheme_Object *modname; - Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name, *nom2; - Scheme_Object *mod_phase; - Scheme_Object *src_phase_index; - Scheme_Object *nominal_src_phase; - Scheme_Object *lex_env; - Scheme_Object *rename_insp; - - if (scheme_hash_get(free_id_recur, id)) { - return id; - } - scheme_hash_set(free_id_recur, id, id); - - nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); - - modname = scheme_stx_module_name(free_id_recur, - &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, - &nominal_name, - &mod_phase, - &src_phase_index, - &nominal_src_phase, - &lex_env, - _sealed, - &rename_insp); - - if (SCHEME_SYMBOLP(nom2)) - nominal_name = nom2; - - if (!modname) - result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false)); - else if (SAME_OBJ(modname, scheme_undefined)) - result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), lex_env)); - else - result = scheme_extend_module_rename(mrn, - modname, - id, /* name in local context */ - orig_id, /* name in definition context */ - nominal_modidx, /* nominal source module */ - nominal_name, /* nominal import before local renaming */ - SCHEME_INT_VAL(mod_phase), /* phase of source defn */ - src_phase_index, /* nominal import phase */ - nominal_src_phase, /* nominal export phase */ - rename_insp, - 3); - - if (*_sealed) { - /* cache the result */ - scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, id, result); - } - - return result; -} - -void scheme_install_free_id_rename(Scheme_Object *id, - Scheme_Object *orig_id, - Scheme_Object *rename_rib, - Scheme_Object *phase) -{ - Scheme_Object *v = NULL, *env, *r_id; - Scheme_Lexical_Rib *rib = NULL; - - if (rename_rib && (SCHEME_RENAMESP(rename_rib) || SCHEME_RENAMES_SETP(rename_rib))) { - /* Install a Module_Rename-level free-id=? rename, instead of at - the level of a lexical-rename. In this case, id is a symbol instead - of an identifier. */ - Module_Renames *rn; - - if (SCHEME_RENAMES_SETP(rename_rib)) - rename_rib = scheme_get_module_rename_from_set(rename_rib, phase, 1); - rn = (Module_Renames *)rename_rib; - - if (!rn->free_id_renames) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - rn->free_id_renames = ht; - } - - scheme_hash_set(rn->free_id_renames, id, orig_id); - - return; - } - - env = scheme_stx_moduleless_env(id); - - if (rename_rib) { - rib = (Scheme_Lexical_Rib *)rename_rib; - } else { - WRAP_POS wl; - - WRAP_POS_INIT(wl, ((Scheme_Stx *)id)->wraps); - while (!WRAP_POS_END_P(wl)) { - v = WRAP_POS_FIRST(wl); - if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) { - break; - } if (SCHEME_RIBP(v)) { - rib = (Scheme_Lexical_Rib *)v; - while (rib) { - if (rib->rename) { - v = rib->rename; - if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) - break; - v = NULL; - } - rib = rib->next; - } - } else - v = NULL; - WRAP_POS_INC(wl); - } - } - - while (v || rib) { - if (!v) { - while (rib) { - if (rib->rename) { - v = rib->rename; - if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) - break; - v = NULL; - } - rib = rib->next; - } - } - - if (v) { - int i, sz; - - sz = SCHEME_RENAME_LEN(v); - for (i = 0; i < sz; i++) { - r_id = SCHEME_VEC_ELS(v)[i+2]; - if (SAME_OBJ(SCHEME_STX_SYM(r_id), SCHEME_STX_VAL(id))) { - /* Install rename: */ - env = SCHEME_VEC_ELS(v)[i+sz+2]; - if (SCHEME_PAIRP(env)) env = SCHEME_CAR(env); - env = CONS(env, CONS(orig_id, phase)); - SCHEME_VEC_ELS(v)[i+sz+2] = env; - return; - } - } - } - - v = NULL; - if (rib) rib = rib->next; - } -} - -Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry) -{ - if (shift || new_midx || export_registry) { - Scheme_Object *vec; - - if (last_phase_shift - && ((vec = SCHEME_BOX_VAL(last_phase_shift))) - && (SCHEME_VEC_ELS(vec)[0] == scheme_make_integer(shift)) - && (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false)) - && (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false)) - && (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false))) { - /* use the old one */ - } else { - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(shift); - SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false); - SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false); - SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false); - - last_phase_shift = scheme_box(vec); - } - - return last_phase_shift; - } else - return NULL; -} - -Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift, - Scheme_Object *old_midx, Scheme_Object *new_midx, - Scheme_Hash_Table *export_registry) -/* Shifts the phase on a syntax object in a module. A 0 shift might be - used just to re-direct relative module paths. new_midx might be - NULL to shift without redirection. And so on. */ -{ - Scheme_Object *ps; - - ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx, export_registry); - if (ps) - return scheme_add_rename(stx, ps); - else - return stx; -} - -void scheme_clear_shift_cache(void) -{ - last_phase_shift = NULL; -} - -static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int len) - /* Mutates o to change its certs, in the case that the first len - elements of owner_wraps includes any phase-shifting (i.e., - modidx-shifting) elements. */ -{ - Scheme_Object *l, *a, *modidx_shift_to = NULL, *modidx_shift_from = NULL, *vec, *src, *dest; - int i, j, cnt; - - for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { - cnt = ((Wrap_Chunk *)a)->len; - for (j = 0; j < cnt; j++) { - if (SCHEME_BOXP(((Wrap_Chunk *)a)->a[j])) { - vec = SCHEME_BOX_VAL(((Wrap_Chunk *)a)->a[j]); - src = SCHEME_VEC_ELS(vec)[1]; - dest = SCHEME_VEC_ELS(vec)[2]; - if (!modidx_shift_to) { - modidx_shift_to = dest; - } else if (!SAME_OBJ(modidx_shift_from, dest)) { - modidx_shift_to = scheme_modidx_shift(dest, - modidx_shift_from, - modidx_shift_to); - } - modidx_shift_from = src; - } - } - } else if (SCHEME_BOXP(a)) { - vec = SCHEME_BOX_VAL(a); - src = SCHEME_VEC_ELS(vec)[1]; - dest = SCHEME_VEC_ELS(vec)[2]; - if (!modidx_shift_to) { - modidx_shift_to = dest; - } else if (!SAME_OBJ(modidx_shift_from, dest)) { - modidx_shift_to = scheme_modidx_shift(dest, - modidx_shift_from, - modidx_shift_to); - } - modidx_shift_from = src; - } - } - - if (modidx_shift_from) { - Scheme_Cert *certs, *acerts, *icerts, *first = NULL, *last = NULL, *c; - Scheme_Object *nc; - int i; - - acerts = ACTIVE_CERTS(((Scheme_Stx *)o)); - icerts = INACTIVE_CERTS(((Scheme_Stx *)o)); - - /* Clone certs list, phase-shifting each cert */ - for (i = 0; i < 2; i++) { - int changed = 0; - - certs = (i ? acerts : icerts); - - first = last = NULL; - while (certs) { - a = scheme_modidx_shift(certs->modidx, modidx_shift_from, modidx_shift_to); - if (!SAME_OBJ(a, certs->modidx)) changed++; - c = cons_cert(certs->mark, a, certs->insp, certs->key, NULL); - c->mapped = certs->mapped; - c->depth = certs->depth; - if (first) - last->next = c; - else - first = c; - last = c; - certs = certs->next; - } - - if (changed) { - if (i) - acerts = first; - else - icerts = first; - } - } - - /* Even if icerts is NULL, may preserve the pair in ->certs, - to indicate no nested inactive certs: */ - { - int no_ia_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs) - && SCHEME_NO_INACTIVE_SUBS_P(((Scheme_Stx *)o)->certs)); - int no_a_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs) - && SCHEME_NO_ACTIVE_SUBS_P(((Scheme_Stx *)o)->certs)); - if (icerts || no_ia_sub || no_a_sub) { - nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts); - if (no_ia_sub) - SCHEME_SET_NO_INACTIVE_SUBS(nc); - if (no_a_sub) - SCHEME_SET_NO_ACTIVE_SUBS(nc); - } else - nc = (Scheme_Object *)acerts; - - ((Scheme_Stx *)o)->certs = nc; - } - } -} - -static Scheme_Object *make_chunk(int len, Scheme_Object *owner_wraps) -/* Result is a single wrap element (possibly a chunk) or a list - of elements in reverse order. */ -{ - Wrap_Chunk *wc; - Scheme_Object *l, *a, *max_chunk_start_list = NULL, *ml; - int i, count = 0, j, max_chunk_size = 0, max_chunk_start_pos = 0; - - if (len > 1) { - for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { - j = ((Wrap_Chunk *)a)->len; - if (j > max_chunk_size) { - max_chunk_start_list = l; - max_chunk_start_pos = i; - max_chunk_size = j; - } - count += j; - } else if (SCHEME_NUMBERP(a)) { - if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l))) - count++; - else { - /* Skip canceling marks */ - i++; - l = SCHEME_CDR(l); - } - } else if (SCHEME_HASHTP(a)) { - /* Don't propagate chain-specific table */ - } else - count++; - } - - if ((max_chunk_size > 8) && ((max_chunk_size * 2) > count)) { - /* It's not worth copying a big existing chunk into - a new chunk. First copy over the part before new chunk, - then the new chunk, and finally the rest. */ - Scheme_Object *ml2; - if (max_chunk_start_pos) { - ml = make_chunk(max_chunk_start_pos, owner_wraps); - if (!SCHEME_PAIRP(ml) && !SCHEME_NULLP(ml)) - ml = scheme_make_pair(ml, scheme_null); - } else - ml = scheme_null; - ml = scheme_make_pair(SCHEME_CAR(max_chunk_start_list), ml); - if (max_chunk_start_pos + 1 < len) { - ml2 = make_chunk(len - 1 - max_chunk_start_pos, - SCHEME_CDR(max_chunk_start_list)); - if (!SCHEME_NULLP(ml2)) { - if (SCHEME_PAIRP(ml2)) - ml = scheme_append(ml2, ml); - else - ml = scheme_make_pair(ml2, ml); - } - } - } else { - if (!count) { - ml = scheme_null; /* everything disappeared! */ - } else { - wc = MALLOC_WRAP_CHUNK(count); - wc->type = scheme_wrap_chunk_type; - wc->len = count; - - ml = NULL; /* to make compiler happy */ - - j = 0; - for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { - int k, cl = ((Wrap_Chunk *)a)->len; - for (k = 0; k < cl; k++) { - wc->a[j++] = ((Wrap_Chunk *)a)->a[k]; - } - } else if (SCHEME_NUMBERP(a)) { - if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l))) - wc->a[j++] = a; - else { - /* Skip canceling marks */ - i++; - l= SCHEME_CDR(l); - } - } else if (SCHEME_HASHTP(a)) { - /* Skip chain-specific table */ - } else - wc->a[j++] = a; - } - - if (count == 1) /* in case mark removal left only one */ - ml = wc->a[0]; - else - ml = (Scheme_Object *)wc; - } - } - } else { - ml = SCHEME_CAR(owner_wraps); - if (SCHEME_HASHTP(ml)) - return scheme_null; - } - - return ml; -} - -#define PREEMPTIVE_CHUNK_THRESHOLD 32 - -static void preemptive_chunk(Scheme_Stx *stx) -{ - int wl_count; - int new_count; - Scheme_Object *here_wraps, *ml; - - /* If the lazy prefix is long, transform it into a chunk. Probably, - some syntax object derived from this one will be unpacked, and - then the lazy prefix will need to be pushed down. - - This chunking fights somewhat with the chain-cache heuristic, - since a chain cache can't be included in a chunk. Still, the - combination seems to work better than either alone for deeply - nested scopes. - - It might also interact badly with simplication or marshaling, - since it decreases chain sharing. This is seems unlikely to - matter, since deeply nested syntax information will be expensive - in any case, and nodes in the wraps are still shared. */ - - wl_count = stx->u.lazy_prefix; - - if (wl_count > PREEMPTIVE_CHUNK_THRESHOLD) { - /* Chunk it */ - here_wraps = stx->wraps; - - ml = make_chunk(wl_count, here_wraps); - - if (SCHEME_PAIRP(ml) || SCHEME_NULLP(ml)) { - new_count = scheme_list_length(ml); - if (new_count == 1) - ml = SCHEME_CAR(ml); - } else { - new_count = 1; - } - - while (wl_count--) { - here_wraps = SCHEME_CDR(here_wraps); - } - wl_count = new_count; - - if (new_count == 1) - here_wraps = scheme_make_pair(ml, here_wraps); - else { - while (new_count--) { - here_wraps = scheme_make_pair(SCHEME_CAR(ml), here_wraps); - ml = SCHEME_CDR(ml); - } - } - - stx->wraps = here_wraps; - stx->u.lazy_prefix = wl_count; - } -} - -static Scheme_Object *propagate_wraps(Scheme_Object *o, - int len, Scheme_Object **_ml, - Scheme_Object *owner_wraps) -{ - int i; - Scheme_Object *ml, *a; - - /* Would adding the wraps generate a list equivalent to owner_wraps? - If so, use owner_wraps directly. But if len is too big, then it - takes too long to check, and so it's better to start chunking. */ - if (len < 128) { - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *p1 = owner_wraps; - Scheme_Object *certs; - - /* Find list after |wl| items in owner_wraps: */ - for (i = 0; i < len; i++) { - p1 = SCHEME_CDR(p1); - } - /* p1 is the list after wl... */ - - if (SAME_OBJ(stx->wraps, p1)) { - /* So, we can use owner_wraps directly instead of building - new wraps. */ - intptr_t lp; - - if (STX_KEY(stx) & STX_SUBSTX_FLAG) - lp = stx->u.lazy_prefix + len; - else - lp = 0; - - certs = stx->certs; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = owner_wraps; - stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */ - stx->certs = certs; - - if (stx->certs) - phase_shift_certs((Scheme_Object *)stx, owner_wraps, len); - - return (Scheme_Object *)stx; - } - } - - ml = *_ml; - if (!ml) { - ml = make_chunk(len, owner_wraps); - *_ml = ml; - } - - if (SCHEME_PAIRP(ml)) { - while (SCHEME_PAIRP(ml)) { - a = SCHEME_CAR(ml); - if (SCHEME_NUMBERP(a)) { - o = scheme_add_remove_mark(o, a); - } else { - o = scheme_add_rename(o, a); - } - ml = SCHEME_CDR(ml); - } - } else if (SCHEME_NUMBERP(ml)) - o = scheme_add_remove_mark(o, ml); - else if (SCHEME_NULLP(ml)) { - /* nothing to add */ - } else - o = scheme_add_rename(o, ml); - - if (((Scheme_Stx *)o)->certs) - phase_shift_certs(o, owner_wraps, len); - - return o; -} - -int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs, - Scheme_Object *home_modidx, Scheme_Object *home_insp) -{ - Scheme_Cert *certs = ACTIVE_CERTS((Scheme_Stx *)stx); - Scheme_Object *cert_modidx, *a, *b; - - do { - while (certs) { - if (!scheme_module_protected_wrt(home_insp, certs->insp)) { - if (home_modidx) { - if (SCHEME_FALSEP(certs->modidx)) - cert_modidx = home_modidx; - else - cert_modidx = certs->modidx; - - a = scheme_module_resolve(home_modidx, 0); - b = scheme_module_resolve(cert_modidx, 0); - } else - a = b = NULL; - - if (SAME_OBJ(a, b)) { - /* Found a certification. Does this identifier have the - associated mark? */ - if (includes_mark(((Scheme_Stx *)stx)->wraps, certs->mark)) - return 1; - } - } - certs = certs->next; - } - if (extra_certs) { - certs = (Scheme_Cert *)extra_certs; - extra_certs = NULL; - } - } while (certs); - - return 0; -} - -static Scheme_Cert *cons_cert(Scheme_Object *mark, Scheme_Object *modidx, - Scheme_Object *insp, Scheme_Object *key, - Scheme_Cert *next_cert) -{ - Scheme_Cert *cert; - - cert = MALLOC_ONE_RT(Scheme_Cert); - cert->iso.so.type = scheme_certifications_type; - cert->mark = mark; - cert->modidx = modidx; - cert->insp = insp; - cert->key = key; - cert->next = next_cert; - cert->depth = (next_cert ? next_cert->depth + 1 : 1); - - if (!key && (!next_cert || CERT_NO_KEY(next_cert))) { - CERT_SET_NO_KEY(cert); - } - - return cert; -} - -#ifdef DO_STACK_CHECK -static void make_mapped(Scheme_Cert *cert); -static Scheme_Object *make_mapped_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Cert *cert = (Scheme_Cert *)p->ku.k.p1; - - p->ku.k.p1 = NULL; - - make_mapped(cert); - - return scheme_void; -} -#endif - -static void make_mapped(Scheme_Cert *cert) -{ - Scheme_Cert *stop, *c2; - Scheme_Object *pr; - Scheme_Hash_Table *ht; - - if (cert->mapped) - return; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)cert; - scheme_handle_stack_overflow(make_mapped_k); - return; - } - } -#endif - SCHEME_USE_FUEL(1); - - if (cert->depth == 16) { - stop = NULL; - } else { - for (stop = cert->next; - stop && ((stop->depth & cert->depth) != stop->depth); - stop = stop->next) { - } - if (stop) - make_mapped(stop); - } - - /* Check whether an `eq?' table will work: */ - for (c2 = cert; c2 != stop; c2 = c2->next) { - if (c2->key) - break; - if (!SCHEME_INTP(c2->mark)) - break; - } - - if (c2 == stop) - ht = scheme_make_hash_table(SCHEME_hash_ptr); - else - ht = scheme_make_hash_table_equal(); - - pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop); - cert->mapped = pr; - - for (; cert != stop; cert = cert->next) { - if (cert->key) - pr = scheme_make_pair(cert->mark, cert->key); - else - pr = cert->mark; - scheme_hash_set_atomic(ht, pr, scheme_true); - } -} - -static int cert_in_chain(Scheme_Object *mark, Scheme_Object *key, Scheme_Cert *cert) -{ - Scheme_Object *hkey = key ? NULL : mark; - Scheme_Hash_Table *ht; - - while (cert) { - if (!(cert->depth & 0xF)) { - make_mapped(cert); - - ht = (Scheme_Hash_Table *)SCHEME_CAR(cert->mapped); - cert = (Scheme_Cert *)SCHEME_CDR(cert->mapped); - - if (!hkey) - hkey = scheme_make_pair(mark, key); - - if (scheme_hash_get_atomic(ht, hkey)) - return 1; - } else if (SAME_OBJ(cert->mark, mark) - && SAME_OBJ(cert->key, key)) { - return 1; - } else - cert = cert->next; - } - - return 0; -} - -static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b) -{ - Scheme_Cert *c; - - if (!a) return b; - if (!b) return a; - - if (a->depth < b->depth) { - c = a; - a = b; - b = c; - } - - c = a; - if (b->depth > (a->depth >> 1)) { - /* There's a good chance that b shares a tail with a, - so check for that, and b is large enough relative to - a that it's worth iterating down to b's depth in a: */ - while (c->depth > b->depth) { - c = c->next; - } - } - - for (; b; b = b->next) { - if (b == c) break; - if (!cert_in_chain(b->mark, b->key, a)) - a = cons_cert(b->mark, b->modidx, b->insp, b->key, a); - c = c->next; - } - - return a; -} - -static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active) -{ - Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs, *check_tail; - Scheme_Stx *stx = (Scheme_Stx *)o, *res; - Scheme_Object *pr; - int shortcut; - - if (!stx->certs) { - if (!certs) - return (Scheme_Object *)stx; - - if (use_key) { - for (cl = certs; cl; cl = cl->next) { - if (!SAME_OBJ(cl->key, use_key)) - break; - } - } else - cl = NULL; - - if (!cl) { - res = (Scheme_Stx *)scheme_make_stx(stx->val, - stx->srcloc, - stx->props); - res->wraps = stx->wraps; - res->u.lazy_prefix = stx->u.lazy_prefix; - if (active) - res->certs = (Scheme_Object *)certs; - else { - pr = scheme_make_raw_pair(NULL, (Scheme_Object *)certs); - res->certs = pr; - } - return (Scheme_Object *)res; - } - } - - if (active) - orig_certs = ACTIVE_CERTS(stx); - else - orig_certs = INACTIVE_CERTS(stx); - now_certs = orig_certs; - - shortcut = 0; - if (now_certs && certs && !use_key && CERT_NO_KEY(certs)) { - if (now_certs->depth < certs->depth) { - /* We can add now_certs onto certs, instead of the other - way around. */ - now_certs = certs; - certs = orig_certs; - } - } - - check_tail = now_certs; - if (check_tail && certs - && (certs->depth > (check_tail->depth >> 1))) { - while (check_tail->depth > certs->depth) { - check_tail = check_tail->next; - } - } - - for (; certs; certs = next_certs) { - next_certs = certs->next; - if (check_tail && (check_tail->depth > certs->depth)) - check_tail = check_tail->next; - if (SAME_OBJ(certs, check_tail)) { - /* tails match --- no need to keep checking */ - break; - } - if (!cert_in_chain(certs->mark, use_key, now_certs)) { - if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) { - now_certs = certs; - next_certs = NULL; - } else { - now_certs = cons_cert(certs->mark, certs->modidx, certs->insp, use_key, - now_certs); - } - } - } - - if (!SAME_OBJ(now_certs, orig_certs)) { - res = (Scheme_Stx *)scheme_make_stx(stx->val, - stx->srcloc, - stx->props); - res->wraps = stx->wraps; - res->u.lazy_prefix = stx->u.lazy_prefix; - if (!active) { - pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs); - res->certs = pr; - if (stx->certs && SCHEME_RPAIRP(stx->certs)) { - if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_INACTIVE_SUBS(pr); - if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_ACTIVE_SUBS(pr); - } - } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) { - pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs)); - res->certs = pr; - if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_INACTIVE_SUBS(pr); - if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_ACTIVE_SUBS(pr); - } else - res->certs = (Scheme_Object *)orig_certs; - stx = res; - - if (!active) { - SCHEME_CDR(stx->certs) = (Scheme_Object *)now_certs; - } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) - SCHEME_CAR(stx->certs) = (Scheme_Object *)now_certs; - else - stx->certs = (Scheme_Object *)now_certs; - } - - return (Scheme_Object *)stx; -} - -Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs) - /* Also lifts existing inactive certs to the top. */ -{ - o = lift_inactive_certs(o, 0); - - return add_certs(o, (Scheme_Cert *)certs, NULL, 0); -} - -Scheme_Object *scheme_stx_propagate_inactive_certs(Scheme_Object *o, Scheme_Object *orig) -{ - Scheme_Cert *certs; - - certs = INACTIVE_CERTS((Scheme_Stx *)orig); - - if (certs) - return scheme_stx_add_inactive_certs(o, (Scheme_Object *)certs); - else - return o; -} - -Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_certs) -{ - return (Scheme_Object *)append_certs((Scheme_Cert *)base_certs, - ACTIVE_CERTS((Scheme_Stx *)o)); -} - -Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env *menv, - Scheme_Object *plus_stx_or_certs, Scheme_Object *key, - int active) - /* If `name' is module-bound, add the module's certification. - Also copy any certifications from plus_stx. - If active and mark is non-NULL, make inactive certificates active. - Existing inactive are lifted when adding from plus_stx_or_certs. */ -{ - if (mark && active) { - o = scheme_stx_activate_certs(o); - } - - if (plus_stx_or_certs) { - Scheme_Cert *certs; - if (SCHEME_STXP(plus_stx_or_certs)) - certs = ACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs); - else - certs = (Scheme_Cert *)plus_stx_or_certs; - if (certs) { - if (!active) - o = lift_inactive_certs(o, 0); - o = add_certs(o, certs, key, active); - } - /* Also copy over inactive certs, if any */ - if (SCHEME_STXP(plus_stx_or_certs)) { - o = lift_inactive_certs(o, 0); - o = add_certs(o, INACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs), key, 0); - } - } - - if (menv && !menv->module->no_cert) { - Scheme_Stx *stx = (Scheme_Stx *)o, *res; - Scheme_Cert *cert; - - res = (Scheme_Stx *)scheme_make_stx(stx->val, - stx->srcloc, - stx->props); - res->wraps = stx->wraps; - res->u.lazy_prefix = stx->u.lazy_prefix; - - if (SCHEME_FALSEP(mark)) { - /* Need to invent a certificate-only mark and apply it */ - mark = scheme_new_mark(); - mark = negate_mark(mark); - res = (Scheme_Stx *)scheme_add_remove_mark((Scheme_Object *)res, mark); - } - - if (active) - cert = ACTIVE_CERTS(stx); - else - cert = INACTIVE_CERTS(stx); - - cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->me->src_modidx, - menv->module->insp, key, cert); - - if (active) { - if (stx->certs && SCHEME_RPAIRP(stx->certs)) { - Scheme_Object *pr; - pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs)); - res->certs = pr; - if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_INACTIVE_SUBS(pr); - if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_ACTIVE_SUBS(pr); - } else - res->certs = (Scheme_Object *)cert; - } else { - Scheme_Object *pr; - pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert); - res->certs = pr; - if (stx->certs && SCHEME_RPAIRP(stx->certs)) { - if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_INACTIVE_SUBS(pr); - if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_ACTIVE_SUBS(pr); - } - } - - o = (Scheme_Object *)res; - } - - return o; -} - -Scheme_Object *scheme_stx_content(Scheme_Object *o) - /* Propagates wraps while getting a syntax object's content. */ -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - - /* The fast-past tests are duplicated in jit.c. */ - - if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && stx->u.lazy_prefix) { - Scheme_Object *v = stx->val, *result; - Scheme_Object *here_wraps; - Scheme_Object *ml = NULL; - int wl_count = 0; - - here_wraps = stx->wraps; - wl_count = stx->u.lazy_prefix; - stx->u.lazy_prefix = 0; - - if (SCHEME_PAIRP(v)) { - Scheme_Object *last = NULL, *first = NULL; - - while (SCHEME_PAIRP(v)) { - Scheme_Object *p; - result = propagate_wraps(SCHEME_CAR(v), wl_count, &ml, here_wraps); - p = scheme_make_pair(result, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) { - result = propagate_wraps(v, wl_count, &ml, here_wraps); - if (last) - SCHEME_CDR(last) = result; - else - first = result; - } - v = first; - } else if (SCHEME_BOXP(v)) { - result = propagate_wraps(SCHEME_BOX_VAL(v), wl_count, &ml, here_wraps); - v = scheme_box(result); - } else if (SCHEME_VECTORP(v)) { - Scheme_Object *v2; - int size = SCHEME_VEC_SIZE(v), i; - - v2 = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - result = propagate_wraps(SCHEME_VEC_ELS(v)[i], wl_count, &ml, here_wraps); - SCHEME_VEC_ELS(v2)[i] = result; - } - - v = v2; - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; - Scheme_Object *key, *val; - int i; - - ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - val = propagate_wraps(val, wl_count, &ml, here_wraps); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - - v = (Scheme_Object *)ht2; - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - Scheme_Object *r; - int size, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - - size = s->stype->num_slots; - for (i = 0; i < size; i++) { - r = propagate_wraps(s->slots[i], wl_count, &ml, here_wraps); - s->slots[i] = r; - } - - v = (Scheme_Object *)s; - } - - stx->val = v; - } - - return stx->val; -} - -Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx) -/* Does not include negative marks */ -{ - WRAP_POS awl; - Scheme_Object *acur_mark, *p, *marks = scheme_null; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - - while (1) { - /* Skip over renames, immediately-canceled marks, and negative marks: */ - acur_mark = NULL; - while (1) { - if (WRAP_POS_END_P(awl)) - break; - p = WRAP_POS_FIRST(awl); - if (SCHEME_NUMBERP(p) && IS_POSMARK(p)) { - if (acur_mark) { - if (SAME_OBJ(acur_mark, p)) { - acur_mark = NULL; - WRAP_POS_INC(awl); - } else - break; - } else { - acur_mark = p; - WRAP_POS_INC(awl); - } - } else { - WRAP_POS_INC(awl); - } - } - - if (acur_mark) { - if (SCHEME_PAIRP(marks) && SAME_OBJ(acur_mark, SCHEME_CAR(marks))) - marks = SCHEME_CDR(marks); - else - marks = scheme_make_pair(acur_mark, marks); - } - - if (WRAP_POS_END_P(awl)) - return scheme_reverse(marks); - } -} - -Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *_stx) -{ - Scheme_Stx *stx = (Scheme_Stx *)_stx; - WRAP_POS awl; - int mod_ctx_count = 0, skipped = 0; - Scheme_Object *v; - Wrap_Chunk *chunk; - - /* Check for module context, first: */ - WRAP_POS_INIT(awl, stx->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (SCHEME_RENAMESP(v) || SCHEME_BOXP(v) || SCHEME_RENAMES_SETP(v)) { - mod_ctx_count++; - } - WRAP_POS_INC(awl); - skipped++; - } - - if (!mod_ctx_count) - return _stx; - - if (mod_ctx_count == skipped) { - /* Everything was a module context? An unlikely but easy case. */ - return scheme_make_stx(stx->val, stx->srcloc, stx->props); - } else { - /* Copy everything else into a new chunk. */ - chunk = MALLOC_WRAP_CHUNK((skipped - mod_ctx_count)); - chunk->type = scheme_wrap_chunk_type; - chunk->len = skipped - mod_ctx_count; - skipped = 0; - WRAP_POS_INIT(awl, stx->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (!SCHEME_RENAMESP(v) && !SCHEME_BOXP(v) && !SCHEME_RENAMES_SETP(v)) { - chunk->a[skipped] = v; - skipped++; - } - WRAP_POS_INC(awl); - } - - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - v = scheme_make_pair((Scheme_Object *)chunk, scheme_null); - stx->wraps = v; - return (Scheme_Object *)stx; - } -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *stx_strip_certs_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Cert **cp = (Scheme_Cert **)p->ku.k.p2; - int active = p->ku.k.i1; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return stx_strip_certs(o, cp, active); -} -#endif - -static Scheme_Object *stx_strip_certs(Scheme_Object *o, Scheme_Cert **cp, int active) -{ -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - Scheme_Cert **_cp; - _cp = MALLOC_N(Scheme_Cert*, 1); - *_cp = *cp; - p->ku.k.p1 = (void *)o; - p->ku.k.p2 = (void *)_cp; - p->ku.k.i1 = active; - o = scheme_handle_stack_overflow(stx_strip_certs_k); - *cp = *_cp; - return o; - } - } -#endif - SCHEME_USE_FUEL(1); - - if (SCHEME_PAIRP(o)) { - Scheme_Object *a, *d; - a = stx_strip_certs(SCHEME_CAR(o), cp, active); - d = stx_strip_certs(SCHEME_CDR(o), cp, active); - if (SAME_OBJ(a, SCHEME_CAR(o)) - && SAME_OBJ(d, SCHEME_CDR(o))) - return o; - return ICONS(a, d); - } else if (SCHEME_NULLP(o)) { - return o; - } else if (SCHEME_BOXP(o)) { - Scheme_Object *c; - c = stx_strip_certs(SCHEME_BOX_VAL(o), cp, active); - if (SAME_OBJ(c, SCHEME_BOX_VAL(o))) - return o; - o = scheme_box(c); - SCHEME_SET_IMMUTABLE(o); - return o; - } else if (SCHEME_VECTORP(o)) { - Scheme_Object *e = NULL, *v2; - int size = SCHEME_VEC_SIZE(o), i, j; - - for (i = 0; i < size; i++) { - e = stx_strip_certs(SCHEME_VEC_ELS(o)[i], cp, active); - if (!SAME_OBJ(e, SCHEME_VEC_ELS(o)[i])) - break; - } - - if (i == size) - return o; - - v2 = scheme_make_vector(size, NULL); - - for (j = 0; j < i; j++) { - SCHEME_VEC_ELS(v2)[j] = SCHEME_VEC_ELS(o)[j]; - } - SCHEME_VEC_ELS(v2)[i] = e; - for (i++; i < size; i++) { - e = stx_strip_certs(SCHEME_VEC_ELS(o)[i], cp, active); - SCHEME_VEC_ELS(v2)[i] = e; - } - - SCHEME_SET_IMMUTABLE(v2); - return v2; - } else if (SCHEME_HASHTRP(o)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o, *ht2; - Scheme_Object *key = NULL, *val, *e, *jkey; - int i, j; - - j = scheme_hash_tree_next(ht, -1); - while (j != -1) { - scheme_hash_tree_index(ht, j, &key, &val); - e = stx_strip_certs(val, cp, active); - if (!SAME_OBJ(e, val)) - break; - j = scheme_hash_tree_next(ht, j); - } - - if (j == -1) - return o; - jkey = key; - - ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); - - i = scheme_hash_tree_next(ht, -1); - while (i != j) { - scheme_hash_tree_index(ht, i, &key, &val); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - ht2 = scheme_hash_tree_set(ht2, key, e); - i = scheme_hash_tree_next(ht, i); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - val = stx_strip_certs(val, cp, active); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - - return (Scheme_Object *)ht2; - } else if (prefab_p(o)) { - Scheme_Object *e = NULL; - Scheme_Structure *s = (Scheme_Structure *)o; - int i, size = s->stype->num_slots; - - for (i = 0; i < size; i++) { - e = stx_strip_certs(s->slots[i], cp, active); - if (!SAME_OBJ(e, s->slots[i])) - break; - } - - if (i == size) - return o; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - s->slots[i] = e; - - for (i++; i < size; i++) { - e = stx_strip_certs(s->slots[i], cp, active); - s->slots[i] = e; - } - - return (Scheme_Object *)s; - } else if (SCHEME_STXP(o)) { - Scheme_Stx *stx = (Scheme_Stx *)o; - - if ((!active && INACTIVE_CERTS(stx)) - || (active && ACTIVE_CERTS(stx))) { - Scheme_Object *np, *v; - Scheme_Stx *res; - Scheme_Cert *certs; - - if ((!active && SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) - || (active && stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs))) { - /* No sub-object has other [in]active certs */ - v = stx->val; - } else { - v = stx_strip_certs(stx->val, cp, active); - } - - res = (Scheme_Stx *)scheme_make_stx(v, - stx->srcloc, - stx->props); - res->wraps = stx->wraps; - res->u.lazy_prefix = stx->u.lazy_prefix; - if (!active) { - if (!ACTIVE_CERTS(stx)) { - if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) - np = no_nested_certs; - else - np = no_nested_inactive_certs; - } else { - np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); - SCHEME_SET_NO_INACTIVE_SUBS(np); - if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_ACTIVE_SUBS(np); - } - } else { - if (!INACTIVE_CERTS(stx)) { - if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) - np = no_nested_certs; - else - np = no_nested_active_certs; - } else { - np = scheme_make_raw_pair(NULL, (Scheme_Object *)INACTIVE_CERTS(stx)); - SCHEME_SET_NO_ACTIVE_SUBS(np); - if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) - SCHEME_SET_NO_INACTIVE_SUBS(np); - } - } - res->certs = np; - - certs = append_certs((active ? ACTIVE_CERTS(stx) : INACTIVE_CERTS(stx)), *cp); - *cp = certs; - - return (Scheme_Object *)res; - } else if (stx->certs - && SCHEME_RPAIRP(stx->certs) - && (active - ? SCHEME_NO_ACTIVE_SUBS_P(stx->certs) - : SCHEME_NO_INACTIVE_SUBS_P(stx->certs))) { - /* Explicit pair, but no [in]active certs anywhere in this object. */ - return (Scheme_Object *)stx; - } else { - Scheme_Stx *res; - Scheme_Object *prev; - - o = stx_strip_certs(stx->val, cp, active); - - if (!SAME_OBJ(o, stx->val)) { - res = (Scheme_Stx *)scheme_make_stx(o, - stx->srcloc, - stx->props); - res->wraps = stx->wraps; - res->u.lazy_prefix = stx->u.lazy_prefix; - } else { - /* No new syntax object, but record the absence of certificates in - sub-parts: */ - res = stx; - } - - prev = stx->certs; - if (!active) { - if (ACTIVE_CERTS(stx)) { - Scheme_Object *np; - np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); - res->certs = np; - SCHEME_SET_NO_INACTIVE_SUBS(np); - if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_ACTIVE_SUBS_P(prev)) - SCHEME_SET_NO_ACTIVE_SUBS(np); - } else if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_ACTIVE_SUBS_P(prev)) - res->certs = no_nested_certs; - else - res->certs = no_nested_inactive_certs; - } else { - if (INACTIVE_CERTS(stx)) { - Scheme_Object *np; - np = scheme_make_raw_pair(NULL, (Scheme_Object *)INACTIVE_CERTS(stx)); - res->certs = np; - SCHEME_SET_NO_ACTIVE_SUBS(np); - if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_INACTIVE_SUBS_P(prev)) - SCHEME_SET_NO_INACTIVE_SUBS(np); - } else if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_INACTIVE_SUBS_P(prev)) - res->certs = no_nested_certs; - else - res->certs = no_nested_active_certs; - } - - return (Scheme_Object *)res; - } - } else - return o; -} - -static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active) -{ - Scheme_Cert *certs = NULL; - - o = stx_strip_certs(o, &certs, 0); - - if (certs) - o = add_certs(o, certs, NULL, as_active); - - return o; -} - -Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o) -{ - return lift_inactive_certs(o, 1); -} - -Scheme_Object *scheme_stx_lift_active_certs(Scheme_Object *o) -{ - Scheme_Cert *certs = NULL; - Scheme_Stx *stx = (Scheme_Stx *)o; - - if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) - return o; - - o = stx_strip_certs(o, &certs, 1); - - if (certs) - o = add_certs(o, certs, NULL, 1); - - return o; -} - -int scheme_stx_has_empty_wraps(Scheme_Object *o) -{ - WRAP_POS awl; - Scheme_Object *mark = NULL, *v; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)o)->wraps); - while (!WRAP_POS_END_P(awl)) { - v = WRAP_POS_FIRST(awl); - if (mark) { - if (!SAME_OBJ(mark, v)) - return 0; - mark = NULL; - } else - mark = v; - WRAP_POS_INC(awl); - } - - return !mark; -} - -/*========================================================================*/ -/* stx comparison */ -/*========================================================================*/ - -/* If no marks and no rename with this set's tag, - then it was an unmarked-but-actually-introduced id. */ - -static Scheme_Object *check_floating_id(Scheme_Object *stx) -{ - /* If `a' has a mzMOD_RENAME_MARKED rename with no following - mzMOD_RENAME_NORMAL using the same set tag, and if there are no - marks after the mzMOD_RENAME_MARKED rename, then we've hit a - corner case: an identifier that was introduced by macro expansion - but marked so that it appears to be original. To ensure that it - gets a generated symbol in the MOD_RENAME_MARKED table, give it a - "floating" binding: scheme_void. This is a rare case, and it more - likely indicates a buggy macro than anything else. */ - WRAP_POS awl; - Scheme_Object *cur_mark = NULL, *searching_identity = NULL, *a; - int no_mark_means_floating = 0; - - WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); - - while (!WRAP_POS_END_P(awl)) { - - a = WRAP_POS_FIRST(awl); - - if (SCHEME_RENAMESP(a) - || SCHEME_RENAMES_SETP(a)) { - int kind; - Scheme_Object *set_identity; - - if (SCHEME_RENAMESP(a)) { - Module_Renames *mrn = (Module_Renames *)a; - - kind = mrn->kind; - set_identity = mrn->set_identity; - } else { - Module_Renames_Set *mrns = (Module_Renames_Set *)a; - - kind = mrns->kind; - set_identity = mrns->set_identity; - } - - if (SAME_OBJ(set_identity, searching_identity)) - searching_identity = NULL; - - if (searching_identity) - no_mark_means_floating = 1; - - if (kind == mzMOD_RENAME_MARKED) - searching_identity = set_identity; - else - searching_identity = NULL; - - } else if (SCHEME_MARKP(a)) { - if (SAME_OBJ(a, cur_mark)) - cur_mark = 0; - else { - if (cur_mark) { - no_mark_means_floating = 0; - searching_identity = NULL; - } - cur_mark = a; - } - } - - WRAP_POS_INC(awl); - } - - if (cur_mark) { - no_mark_means_floating = 0; - searching_identity = NULL; - } - - if (searching_identity || no_mark_means_floating) - return scheme_void; - - return scheme_false; -} - -#define EXPLAIN_RESOLVE 0 -#if EXPLAIN_RESOLVE -int scheme_explain_resolves = 0; -# define EXPLAIN(x) if (scheme_explain_resolves) { x; } -#else -# define EXPLAIN(x) /* empty */ -#endif - -static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) -/* Compares the marks in two wraps lists. A result of 2 means that the - result depended on a barrier env. For a rib-based renaming, we need - to check only up to the rib, and the barrier effect important for - when a rib-based renaming is layered with another renaming (such as - when an internal-definition-base local-expand is used to form a new - set of bindings, as in the unit form); simplification cleans up the - layers, so that we only need to check in ribs. */ -{ - WRAP_POS awl; - WRAP_POS bwl; - Scheme_Object *acur_mark, *bcur_mark; -# define FAST_STACK_SIZE 4 - Scheme_Object *a_mark_stack_fast[FAST_STACK_SIZE], *b_mark_stack_fast[FAST_STACK_SIZE]; - Scheme_Object **a_mark_stack = a_mark_stack_fast, **b_mark_stack = b_mark_stack_fast, **naya; - int a_mark_cnt = 0, a_mark_size = FAST_STACK_SIZE, b_mark_cnt = 0, b_mark_size = FAST_STACK_SIZE; - int used_barrier = 0; - - WRAP_POS_COPY(awl, *_awl); - WRAP_POS_COPY(bwl, *_bwl); - - /* A simple way to compare marks would be to make two lists of - marks. The loop below attempts to speed up that process by - discovering common and canceled marks early, so they can be - omitted from the lists. The "stack" arrays accumulate the parts - of the list that can't be skipped that way. */ - - while (1) { - /* Skip over renames and canceled marks: */ - acur_mark = NULL; - while (1) { /* loop for canceling stack */ - /* this loop handles immediately canceled marks */ - while (1) { - if (WRAP_POS_END_P(awl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl)) && IS_POSMARK(WRAP_POS_FIRST(awl))) { - if (acur_mark) { - if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { - acur_mark = NULL; - WRAP_POS_INC(awl); - } else - break; - } else { - acur_mark = WRAP_POS_FIRST(awl); - WRAP_POS_INC(awl); - } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) { - if (SCHEME_FALSEP(barrier_env)) { - WRAP_POS_INC(awl); - } else { - /* See if the barrier environment is in this rib. */ - Scheme_Lexical_Rib *rib; - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(awl); - for (rib = rib->next; rib; rib = rib->next) { - if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) - break; - } - if (!rib) { - WRAP_POS_INC(awl); - } else { - WRAP_POS_INIT_END(awl); - used_barrier = 1; - } - } - } else { - WRAP_POS_INC(awl); - } - } - /* Maybe cancel a mark on the stack */ - if (acur_mark && a_mark_cnt) { - if (SAME_OBJ(acur_mark, a_mark_stack[a_mark_cnt - 1])) { - --a_mark_cnt; - if (a_mark_cnt) { - acur_mark = a_mark_stack[a_mark_cnt - 1]; - --a_mark_cnt; - break; - } else - acur_mark = NULL; - } else - break; - } else - break; - } - - bcur_mark = NULL; - while (1) { /* loop for canceling stack */ - while (1) { - if (WRAP_POS_END_P(bwl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(bwl)) && IS_POSMARK(WRAP_POS_FIRST(bwl))) { - if (bcur_mark) { - if (SAME_OBJ(bcur_mark, WRAP_POS_FIRST(bwl))) { - bcur_mark = NULL; - WRAP_POS_INC(bwl); - } else - break; - } else { - bcur_mark = WRAP_POS_FIRST(bwl); - WRAP_POS_INC(bwl); - } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) { - if (SCHEME_FALSEP(barrier_env)) { - WRAP_POS_INC(bwl); - } else { - /* See if the barrier environment is in this rib. */ - Scheme_Lexical_Rib *rib; - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(bwl); - for (rib = rib->next; rib; rib = rib->next) { - if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) - break; - } - if (!rib) { - WRAP_POS_INC(bwl); - } else { - WRAP_POS_INIT_END(bwl); - used_barrier = 1; - } - } - } else { - WRAP_POS_INC(bwl); - } - } - /* Maybe cancel a mark on the stack */ - if (bcur_mark && b_mark_cnt) { - if (SAME_OBJ(bcur_mark, b_mark_stack[b_mark_cnt - 1])) { - --b_mark_cnt; - if (b_mark_cnt) { - bcur_mark = b_mark_stack[b_mark_cnt - 1]; - --b_mark_cnt; - break; - } else - bcur_mark = NULL; - } else - break; - } else - break; - } - - /* Same mark? */ - if (a_mark_cnt || b_mark_cnt || !SAME_OBJ(acur_mark, bcur_mark)) { - /* Not the same, so far; push onto stacks in case they're - cancelled later */ - if (acur_mark) { - if (a_mark_cnt >= a_mark_size) { - a_mark_size *= 2; - naya = MALLOC_N(Scheme_Object*, a_mark_size); - memcpy(naya, a_mark_stack, sizeof(Scheme_Object *)*a_mark_cnt); - a_mark_stack = naya; - } - a_mark_stack[a_mark_cnt++] = acur_mark; - } - if (bcur_mark) { - if (b_mark_cnt >= b_mark_size) { - b_mark_size *= 2; - naya = MALLOC_N(Scheme_Object*, b_mark_size); - memcpy(naya, b_mark_stack, sizeof(Scheme_Object *)*b_mark_cnt); - b_mark_stack = naya; - } - b_mark_stack[b_mark_cnt++] = bcur_mark; - } - } - - /* Done if both reached the end: */ - if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) { - EXPLAIN(fprintf(stderr, " %d vs. %d marks\n", a_mark_cnt, b_mark_cnt)); - if (a_mark_cnt == b_mark_cnt) { - while (a_mark_cnt--) { - if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt])) - return 0; - } - return used_barrier + 1; - } else - return 0; - } - } -} - -static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark) -/* Checks for positive or negative (certificate-only) mark. - FIXME: canceling marks are detected only when they're immediately - canceling (i.e., no canceled marks in between). */ -{ - WRAP_POS awl; - Scheme_Object *acur_mark; - - WRAP_POS_INIT(awl, wraps); - - while (1) { - /* Skip over renames and cancelled marks: */ - acur_mark = NULL; - while (1) { - if (WRAP_POS_END_P(awl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) { - if (acur_mark) { - if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { - acur_mark = NULL; - WRAP_POS_INC(awl); - } else - break; - } else { - acur_mark = WRAP_POS_FIRST(awl); - WRAP_POS_INC(awl); - } - } else { - WRAP_POS_INC(awl); - } - } - - /* Same mark? */ - if (SAME_OBJ(acur_mark, mark)) - return 1; - - if (WRAP_POS_END_P(awl)) - return 0; - } -} - -static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) -/* Adds both positive and negative marks to marks table. This may add too many - marks, because it detects only immediately canceling marks. */ -{ - WRAP_POS awl; - Scheme_Object *acur_mark; - - WRAP_POS_INIT(awl, wraps); - - while (1) { - /* Skip over renames and cancelled marks: */ - acur_mark = NULL; - while (1) { - if (WRAP_POS_END_P(awl)) - break; - if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) { - if (acur_mark) { - if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { - acur_mark = NULL; - WRAP_POS_INC(awl); - } else - break; - } else { - acur_mark = WRAP_POS_FIRST(awl); - WRAP_POS_INC(awl); - } - } else { - WRAP_POS_INC(awl); - } - } - - if (acur_mark) - scheme_hash_set(marks, acur_mark, scheme_true); - else - return; - } -} - -static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth, - int *_skipped) -{ - int l1, l2; - Scheme_Object *m1, *m2; - - p = SCHEME_CDR(p); /* skip modidx */ - p = SCHEME_CDR(p); /* skip phase_export */ - if (SCHEME_PAIRP(p)) { - /* has marks */ - int skip = 0; - - EXPLAIN(fprintf(stderr, "%d has marks\n", depth)); - - m1 = SCHEME_CAR(p); - if (*marks_cache) - m2 = *marks_cache; - else { - EXPLAIN(fprintf(stderr, "%d extract marks\n", depth)); - m2 = scheme_stx_extract_marks(orig_id); - *marks_cache = m2; - } - - l1 = scheme_list_length(m1); - l2 = scheme_list_length(m2); - - if (l2 < l1) return -1; /* no match */ - - while (l2 > l1) { - m2 = SCHEME_CDR(m2); - l2--; - skip++; - } - - if (scheme_equal(m1, m2)) { - if (_skipped ) *_skipped = skip; - return l1; /* matches */ - } else - return -1; /* no match */ - } else { - if (_skipped) *_skipped = -1; - return 0; /* match empty mark set */ - } -} - - -void scheme_populate_pt_ht(Scheme_Module_Phase_Exports * pt) { - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - Scheme_Hash_Table *ht; - int i; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - for (i = pt->num_provides; i--; ) { - scheme_hash_set(ht, pt->provides[i], scheme_make_integer(i)); - } - pt->ht = ht; - } -} - -static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, - Scheme_Object *glob_id, Scheme_Object *orig_id, - Scheme_Object **get_names, int get_orig_name, - int depth, - int *_skipped) -{ - Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; - Scheme_Module_Phase_Exports *pt; - int i, phase, best_match_len = -1, skip = 0; - Scheme_Object *marks_cache = NULL; - - for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { - pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); - - EXPLAIN(fprintf(stderr, "%d pes table %s\n", depth, - pt->src_modidx - ? scheme_write_to_string(scheme_module_resolve(pt->src_modidx, 0), NULL) - : "?")); - - if (!pt->ht) { - /* Lookup table (which is created lazily) not yet created, so do that now... */ - EXPLAIN(fprintf(stderr, "%d {create lookup}\n", depth)); - scheme_populate_pt_ht(pt); - } - - pos = scheme_hash_get(pt->ht, glob_id); - if (pos) { - /* Found it, maybe. Check marks. */ - int mark_len; - EXPLAIN(fprintf(stderr, "%d found %p\n", depth, pos)); - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip); - if (mark_len > best_match_len) { - /* Marks match and improve on previously found match. Build suitable rename: */ - best_match_len = mark_len; - if (_skipped) *_skipped = skip; - - idx = SCHEME_CAR(SCHEME_CAR(pr)); - - i = SCHEME_INT_VAL(pos); - - if (get_orig_name) - best_match = pt->provide_src_names[i]; - else { - if (pt->provide_srcs) - src = pt->provide_srcs[i]; - else - src = scheme_false; - - if (get_names) { - /* If module bound, result is module idx, and get_names[0] is set to source name, - get_names[1] is set to the nominal source module, get_names[2] is set to - the nominal source module's export, get_names[3] is set to the phase of - the source definition, get_names[4] is set to the module import phase index, - and get_names[5] is set to the nominal export phase */ - - if (pt->provide_src_phases) - phase = pt->provide_src_phases[i]; - else - phase = 0; - - EXPLAIN(fprintf(stderr, "%d srcname %s\n", depth, SCHEME_SYM_VAL(pt->provide_src_names[i]))); - get_names[0] = pt->provide_src_names[i]; - get_names[1] = idx; - get_names[2] = glob_id; - get_names[3] = scheme_make_integer(phase); - get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr))); - if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */ - get_names[4] = SCHEME_CDR(get_names[4]); - get_names[5] = pt->phase_index; - get_names[6] = (pt->provide_insps ? pt->provide_insps[i] : NULL); - } - - if (SCHEME_FALSEP(src)) { - src = idx; - } else { - src = scheme_modidx_shift(src, pt->src_modidx, idx); - } - - best_match = src; - } - } - } - } - - return best_match; -} - -static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *phase) -{ - if (SAME_OBJ(phase, scheme_make_integer(0))) - return mrns->rt; - else if (SAME_OBJ(phase, scheme_make_integer(1))) - return mrns->et; - else if (mrns->other_phases) - return (Module_Renames *)scheme_hash_get(mrns->other_phases, phase); - else - return NULL; -} - -static int nonempty_rib(Scheme_Lexical_Rib *rib) -{ - rib = rib->next; - - while (rib) { - if (SCHEME_RENAME_LEN(rib->rename)) - return 1; - rib = rib->next; - } - - return 0; -} - -static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) -{ - if (!skip_ribs) - return 0; - - if (scheme_hash_tree_get((Scheme_Hash_Tree *)skip_ribs, timestamp)) - return 1; - - return 0; -} - -static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) -{ - if (in_skip_set(timestamp, skip_ribs)) - return skip_ribs; - - if (!skip_ribs) - skip_ribs = (Scheme_Object *)scheme_make_hash_tree(1); - - skip_ribs = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)skip_ribs, timestamp, scheme_true); - - { - Scheme_Bucket *b; - scheme_start_atomic(); - b = scheme_bucket_from_table(interned_skip_ribs, (const char *)skip_ribs); - scheme_end_atomic_no_swap(); - if (!b->val) - b->val = scheme_true; - - skip_ribs = (Scheme_Object *)HT_EXTRACT_WEAK(b->key); - } - - return skip_ribs; -} - -XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b) -{ - return SAME_OBJ(a, b); -} - -XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs) -{ - Scheme_Object *p; - - if (SCHEME_PAIRP(other_env)) { - /* paired with free-id=? rename */ - other_env = SCHEME_CAR(other_env); - } - - if (SCHEME_MPAIRP(other_env)) { - other_env = SCHEME_CAR(other_env); - if (!other_env) - return scheme_void; - } - - if (SCHEME_RPAIRP(other_env)) { - while (other_env) { - p = SCHEME_CAR(other_env); - if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) { - return SCHEME_CDR(p); - } - other_env = SCHEME_CDR(other_env); - } - return scheme_void; - } else if (!skip_ribs) - return other_env; - else - return scheme_void; -} - -static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs, - int depends_on_unsealed_rib) -{ - Scheme_Object *in_mpair = NULL; - Scheme_Object *free_id_rename = NULL; - - if (SCHEME_PAIRP(orig)) { - free_id_rename = SCHEME_CDR(orig); - orig = SCHEME_CAR(orig); - } - - if (SCHEME_MPAIRP(orig)) { - in_mpair = orig; - orig = SCHEME_CAR(orig); - if (!depends_on_unsealed_rib && !orig) { - /* no longer depends on unsealed rib: */ - in_mpair = NULL; - orig = scheme_void; - } else { - /* (some) still depends on unsealed rib: */ - if (!orig) { - /* re-register in list of dependencies */ - SCHEME_CDR(in_mpair) = unsealed_dependencies; - unsealed_dependencies = in_mpair; - orig = scheme_void; - } - } - } else if (depends_on_unsealed_rib) { - /* register dependency: */ - in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies); - unsealed_dependencies = in_mpair; - } - - if (SCHEME_VOIDP(orig) && !skip_ribs) { - orig = other_env; - } else { - if (!SCHEME_RPAIRP(orig)) - orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL); - - orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig); - } - - if (in_mpair) { - SCHEME_CAR(in_mpair) = orig; - orig = in_mpair; - } - - if (free_id_rename) { - orig = CONS(orig, free_id_rename); - } - - return orig; -} - -static void extract_lex_range(Scheme_Object *rename, Scheme_Object *a, int *_istart, int *_iend) -{ - int istart, iend, c; - - c = SCHEME_RENAME_LEN(rename); - - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { - void *pos; - pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), a); - if (pos) { - istart = SCHEME_INT_VAL(pos); - if (istart < 0) { - /* -1 indicates multiple slots matching this name. */ - istart = 0; - iend = c; - } else - iend = istart + 1; - } else { - istart = 0; - iend = 0; - } - } else { - istart = 0; - iend = c; - } - - *_istart = istart; - *_iend = iend; -} - -/* This needs to be a multiple of 4: */ -#define QUICK_STACK_SIZE 16 - -/* Although resolve_env may call itself recursively, the recursion - depth is bounded (by the fact that modules can't be nested, - etc.). */ - -static Scheme_Object *resolve_env(WRAP_POS *_wraps, - Scheme_Object *a, Scheme_Object *orig_phase, - int w_mod, Scheme_Object **get_names, - Scheme_Object *skip_ribs, int *_binding_marks_skipped, - int *_depends_on_unsealed_rib, int depth, - Scheme_Hash_Table *free_id_recur) -/* Module binding ignored if w_mod is 0. - If module bound, result is module idx, and get_names[0] is set to source name, - get_names[1] is set to the nominal source module, get_names[2] is set to - the nominal source module's export, get_names[3] is set to the phase of - the source definition, and get_names[4] is set to the nominal import phase index, - and get_names[5] is set to the nominal export phase; get_names[6] is set to - an inspector/pair if one applies for a re-export of a protected or unexported, NULL or - #f otherwise. - If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined; - get_names[1] is set if a free-id=? rename provides a different name for the bindig. - If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1] - is set if a free-id=? rename provides a different name. */ -{ - WRAP_POS wraps; - Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; - Scheme_Object *mresult = scheme_false, *mresult_insp; - Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; - Scheme_Object *rename_stack[QUICK_STACK_SIZE], *rib_delim = scheme_false; - int stack_pos = 0, no_lexical = 0; - int is_in_module = 0, skip_other_mods = 0, floating_checked = 0; - Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL; - Scheme_Object *phase = orig_phase; - Scheme_Object *bdg = NULL, *floating = NULL; - Scheme_Hash_Table *export_registry = NULL; - int mresult_skipped = -1; - int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0; - - EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), - scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); - - if (_wraps) { - WRAP_POS_COPY(wraps, *_wraps); - WRAP_POS_INC(wraps); - } else - WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); - - while (1) { - if (WRAP_POS_END_P(wraps)) { - /* See rename case for info on rename_stack: */ - Scheme_Object *result, *result_free_rename, *key, *rd; - int did_lexical = 0; - - EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); - - result = scheme_false; - result_free_rename = scheme_false; - rib_delim = scheme_null; - while (!SCHEME_NULLP(o_rename_stack)) { - key = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[0]; - if (SAME_OBJ(key, result)) { - EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); - did_lexical = 1; - rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3]; - if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { - /* not a match, due to rib delimiter */ - } else { - result = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[1]; - result_free_rename = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[2]; - rib_delim = rd; - } - } else { - EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); - if (SAME_OBJ(key, scheme_true)) { - /* marks a module-level renaming that overrides lexical renaming */ - did_lexical = 0; - } - } - o_rename_stack = SCHEME_CDR(o_rename_stack); - } - while (stack_pos) { - key = rename_stack[stack_pos - 1]; - if (SAME_OBJ(key, result)) { - EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); - rd = rename_stack[stack_pos - 4]; - if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { - /* not a match, due to rib delimiter */ - } else { - result = rename_stack[stack_pos - 2]; - result_free_rename = rename_stack[stack_pos - 3]; - rib_delim = rd; - did_lexical = 1; - } - } else { - EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); - if (SAME_OBJ(key, scheme_true)) { - /* marks a module-level renaming that overrides lexical renaming */ - did_lexical = 0; - } - } - stack_pos -= 4; - } - if (!did_lexical) { - result = mresult; - if (_binding_marks_skipped) - *_binding_marks_skipped = mresult_skipped; - if (mresult_depends_unsealed) - depends_on_unsealed_rib = 1; - } else { - if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) { - Scheme_Object *orig; - int rib_dep = 0; - orig = result_free_rename; - result_free_rename = SCHEME_VEC_ELS(orig)[0]; - if (SCHEME_PAIRP(result_free_rename) && SCHEME_STXP(SCHEME_CAR(result_free_rename))) { - phase = SCHEME_CDR(result_free_rename); - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(orig)[1])) - phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]); - if (get_names) - get_names[1] = NULL; - result = SCHEME_CAR(result_free_rename); - if (!scheme_hash_get(free_id_recur, result)) { - scheme_hash_set(free_id_recur, result, scheme_true); - result = resolve_env(NULL, result, phase, - w_mod, get_names, - NULL, _binding_marks_skipped, - &rib_dep, depth + 1, free_id_recur); - } - if (get_names && !get_names[1]) - if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) - get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); - } else if (SCHEME_PAIRP(result_free_rename) && SCHEME_SYMBOLP(SCHEME_CDR(result_free_rename))) { - if (get_names) - get_names[1] = SCHEME_CAR(result_free_rename); - result = SCHEME_CDR(result_free_rename); - if (get_names) - get_names[0] = scheme_undefined; - } else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) { - result = SCHEME_VEC_ELS(result_free_rename)[0]; - if (get_names) { - get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1]; - get_names[1] = SCHEME_VEC_ELS(result_free_rename)[2]; - get_names[2] = SCHEME_VEC_ELS(result_free_rename)[3]; - get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4]; - get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5]; - get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6]; - get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7]; - } - } else { - if (get_names) - get_names[1] = SCHEME_CAR(result_free_rename); - result = scheme_false; - } - if (rib_dep) - depends_on_unsealed_rib = 1; - if (SAME_TYPE(SCHEME_TYPE(result), scheme_module_index_type)) - result = scheme_modidx_shift(result, SCHEME_VEC_ELS(orig)[2], SCHEME_VEC_ELS(orig)[3]); - } else { - if (get_names) { - get_names[0] = scheme_undefined; - get_names[1] = NULL; - } - } - } - - if (_depends_on_unsealed_rib) - *_depends_on_unsealed_rib = depends_on_unsealed_rib; - - EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, 0))); - - return result; - } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) - || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) - && w_mod) { - /* Module rename: */ - Module_Renames *mrn; - int skipped; - - EXPLAIN(fprintf(stderr, "%d Rename/set\n", depth)); - - if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { - mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); - } else { - /* Extract the relevant phase, if available */ - Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps); - - if (mrns->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - mrn = extract_renames(mrns, phase); - } - - if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) - && !skip_other_mods) { - if (mrn->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - if (same_phase(phase, mrn->phase)) { - Scheme_Object *rename, *nominal = NULL, *glob_id; - int get_names_done; - - EXPLAIN(fprintf(stderr, "%d use rename %p %d\n", depth, mrn->phase, mrn->kind)); - - if (mrn->needs_unmarshal) { - EXPLAIN(fprintf(stderr, "%d {unmarshal}\n", depth)); - unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry); - } - - if (mrn->marked_names) { - /* Resolve based on rest of wraps: */ - EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); - if (!bdg) { - EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL); - if (SCHEME_FALSEP(bdg)) { - if (!floating_checked) { - floating = check_floating_id(a); - floating_checked = 1; - } - bdg = floating; - } - } - /* Remap id based on marks and rest-of-wraps resolution: */ - glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped); - - if (SCHEME_TRUEP(bdg) - && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { - /* Even if this module doesn't match, the lex-renamed id - has been top-level bound in its scope, so ignore all - lexical renamings. (If the id was further renamed, then - the further renaming would show up in bdg, and bdg wouldn't - have matched in marked_names.) */ - no_lexical = 1; - stack_pos = 0; - o_rename_stack = scheme_null; - } - } else { - skipped = -1; - glob_id = SCHEME_STX_VAL(a); - } - - EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); - - if (free_id_recur && mrn->free_id_renames) { - rename = scheme_hash_get(mrn->free_id_renames, glob_id); - if (rename && SCHEME_STXP(rename)) { - int sealed; - rename = extract_module_free_id_binding((Scheme_Object *)mrn, - glob_id, - rename, - &sealed, - free_id_recur); - if (!sealed) - mresult_depends_unsealed = 1; - } - } else - rename = NULL; - if (!rename) - rename = scheme_hash_get(mrn->ht, glob_id); - if (!rename && mrn->nomarshal_ht) - rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - get_names_done = 0; - if (!rename) { - EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); - rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth, &skipped); - if (rename) - get_names_done = 1; - } - - EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename)); - - if (rename) { - if (mrn->sealed < STX_SEAL_BOUND) - mresult_depends_unsealed = 1; - - if (mrn->kind == mzMOD_RENAME_MARKED) { - /* One job of a mzMOD_RENAME_MARKED renamer is to replace any - binding that might have come from the identifier in its source - module, instead of the module where it was eventually bound - (after being introduced by a macro in the source module). */ - skip_other_mods = 1; - } - - /* match; set mresult, which is used in the case of no lexical capture: */ - mresult_skipped = skipped; - - mresult_insp = NULL; - - if (SCHEME_BOXP(rename)) { - /* This should only happen for mappings from free_id_renames */ - mresult = SCHEME_BOX_VAL(rename); - if (get_names) { - if (SCHEME_FALSEP(SCHEME_CDR(mresult))) - get_names[0] = NULL; - else - get_names[0] = scheme_undefined; - get_names[1] = SCHEME_CAR(mresult); - } - mresult = SCHEME_CDR(mresult); - } else { - if (SCHEME_PAIRP(rename)) { - mresult = SCHEME_CAR(rename); - if (is_rename_inspector_info(mresult)) { - mresult_insp = mresult; - rename = SCHEME_CDR(rename); - mresult = SCHEME_CAR(rename); - } - } else - mresult = rename; - - if (modidx_shift_from) - mresult = scheme_modidx_shift(mresult, - modidx_shift_from, - modidx_shift_to); - - if (get_names) { - int no_shift = 0; - - if (!get_names_done) { - if (SCHEME_PAIRP(rename)) { - if (nom_mod_p(rename)) { - /* (cons modidx nominal_modidx) case */ - get_names[0] = glob_id; - get_names[1] = SCHEME_CDR(rename); - get_names[2] = get_names[0]; - } else { - rename = SCHEME_CDR(rename); - if (SCHEME_PAIRP(rename)) { - /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ - if (SCHEME_INTP(SCHEME_CAR(rename)) - || SCHEME_FALSEP(SCHEME_CAR(rename))) { - get_names[3] = SCHEME_CAR(rename); - rename = SCHEME_CDR(rename); - } - get_names[0] = SCHEME_CAR(rename); - get_names[1] = SCHEME_CADR(rename); - if (SCHEME_PAIRP(get_names[1])) { - get_names[4] = SCHEME_CDR(get_names[1]); - get_names[1] = SCHEME_CAR(get_names[1]); - if (SCHEME_PAIRP(get_names[4])) { - get_names[5] = SCHEME_CDR(get_names[4]); - get_names[4] = SCHEME_CAR(get_names[4]); - } else { - get_names[5] = get_names[3]; - } - } - get_names[2] = SCHEME_CDDR(rename); - } else { - /* (cons modidx exportname) case */ - get_names[0] = rename; - get_names[2] = NULL; /* finish below */ - } - } - } else { - get_names[0] = glob_id; - get_names[2] = NULL; /* finish below */ - } - - if (!get_names[2]) { - get_names[2] = get_names[0]; - if (nominal) - get_names[1] = nominal; - else { - no_shift = 1; - get_names[1] = mresult; - } - } - if (!get_names[4]) { - GC_CAN_IGNORE Scheme_Object *pi; - pi = phase_to_index(mrn->phase); - get_names[4] = pi; - } - if (!get_names[5]) { - get_names[5] = get_names[3]; - } - get_names[6] = mresult_insp; - } - - if (modidx_shift_from && !no_shift) { - Scheme_Object *nom; - nom = get_names[1]; - nom = scheme_modidx_shift(nom, - modidx_shift_from, - modidx_shift_to); - get_names[1] = nom; - } - } - } - } else { - if (mrn->sealed < STX_SEAL_ALL) - mresult_depends_unsealed = 1; - mresult = scheme_false; - mresult_skipped = -1; - if (get_names) - get_names[0] = NULL; - } - } - } - } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps)) && w_mod) { - /* Phase shift */ - Scheme_Object *vec, *n, *dest, *src; - - EXPLAIN(fprintf(stderr, "%d phase shift\n", depth)); - - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); - n = SCHEME_VEC_ELS(vec)[0]; - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_minus(phase, n); - - src = SCHEME_VEC_ELS(vec)[1]; - dest = SCHEME_VEC_ELS(vec)[2]; - - /* If src is #f, shift is just for phase; no redirection */ - - if (!SCHEME_FALSEP(src)) { - if (!modidx_shift_to) { - modidx_shift_to = dest; - } else if (!SAME_OBJ(modidx_shift_from, dest)) { - modidx_shift_to = scheme_modidx_shift(dest, - modidx_shift_from, - modidx_shift_to); - } - - modidx_shift_from = src; - } - - { - Scheme_Object *er; - er = SCHEME_VEC_ELS(vec)[3]; - if (SCHEME_TRUEP(er)) - export_registry = (Scheme_Hash_Table *)er; - } - } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) - && !no_lexical)) { - /* Lexical rename: */ - Scheme_Object *rename, *renamed; - int ri, c, istart, iend; - Scheme_Lexical_Rib *is_rib; - - if (rib) { - rename = rib->rename; - is_rib = rib; - rib = rib->next; - } else { - rename = WRAP_POS_FIRST(wraps); - is_rib = NULL; - did_rib = NULL; - } - - EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0, - SCHEME_VEC_SIZE(rename), - SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "", - SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash")); - - c = SCHEME_RENAME_LEN(rename); - - /* Get index from hash table, if there is one: */ - extract_lex_range(rename, SCHEME_STX_VAL(a), &istart, &iend); - - for (ri = istart; ri < iend; ri++) { - renamed = SCHEME_VEC_ELS(rename)[2+ri]; - if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { - int same; - - { - Scheme_Object *other_env, *envname, *free_id_rename; - - if (SCHEME_SYMBOLP(renamed)) { - /* Simplified table */ - other_env = scheme_false; - envname = SCHEME_VEC_ELS(rename)[2+c+ri]; - if (SCHEME_PAIRP(envname)) { - free_id_rename = SCHEME_CDR(envname); - envname = SCHEME_CAR(envname); - } else - free_id_rename = scheme_void; - same = 1; - no_lexical = 1; /* simplified table always has final result */ - EXPLAIN(fprintf(stderr, "%d Targes %s <- %s %p\n", depth, - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0), - free_id_rename)); - } else { - envname = SCHEME_VEC_ELS(rename)[0]; - other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; - if (SCHEME_PAIRP(other_env)) - free_id_rename = SCHEME_CDR(other_env); - else - free_id_rename = scheme_void; - other_env = filter_cached_env(other_env, recur_skip_ribs); - - if (SCHEME_VOIDP(other_env)) { - int rib_dep = 0; - SCHEME_USE_FUEL(1); - other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL); - { - Scheme_Object *e; - e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, - (is_rib && !(*is_rib->sealed)) || rib_dep); - SCHEME_VEC_ELS(rename)[2+c+ri] = e; - } - if (rib_dep) - depends_on_unsealed_rib = 1; - SCHEME_USE_FUEL(1); - } - - EXPLAIN(fprintf(stderr, "%d Target %s <- %s (%d)\n", depth, - scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0), - nom_mod_p(rename))); - - { - WRAP_POS w2; - WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps); - same = same_marks(&w2, &wraps, other_env); - if (!same) - EXPLAIN(fprintf(stderr, "%d Different marks\n", depth)); - } - } - - if (same) { - /* If it turns out that we're going to return - other_env, then return envname instead. - It's tempting to try to compare envname to the - top element of the stack and combine the two - mappings, but the intermediate name may be needed - (for other_env values that don't come from this stack). */ - if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) { - /* Need to remember phase ad shifts for free-id=? rename: */ - Scheme_Object *vec; - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = free_id_rename; - SCHEME_VEC_ELS(vec)[1] = phase; - SCHEME_VEC_ELS(vec)[2] = modidx_shift_from; - SCHEME_VEC_ELS(vec)[3] = modidx_shift_to; - free_id_rename = vec; - } - if (stack_pos < QUICK_STACK_SIZE) { - rename_stack[stack_pos++] = rib_delim; - rename_stack[stack_pos++] = free_id_rename; - rename_stack[stack_pos++] = envname; - rename_stack[stack_pos++] = other_env; - } else { - Scheme_Object *vec; - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = other_env; - SCHEME_VEC_ELS(vec)[1] = envname; - SCHEME_VEC_ELS(vec)[2] = free_id_rename; - SCHEME_VEC_ELS(vec)[3] = rib_delim; - o_rename_stack = CONS(vec, o_rename_stack); - } - if (is_rib) { - /* skip future instances of the same rib; - used to skip the rest of the current rib, too, but - that's wrong in the case that the same symbolic - name with multiple binding contexts is re-bound - in a rib */ - skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs); - } - } - - break; - } - } - } - } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) { - /* Lexical-rename rib. Splice in the names. */ - rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); - EXPLAIN(fprintf(stderr, "%d Rib: %p...\n", depth, rib)); - if (skip_ribs) { - if (in_skip_set(rib->timestamp, skip_ribs)) { - EXPLAIN(fprintf(stderr, "%d Skip rib\n", depth)); - rib = NULL; - } - } - if (rib) { - if (!*rib->sealed) - depends_on_unsealed_rib = 1; - if (nonempty_rib(rib)) { - if (SAME_OBJ(did_rib, rib)) { - EXPLAIN(fprintf(stderr, "%d Did rib\n", depth)); - rib = NULL; - } else { - recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); - did_rib = rib; - if (rib->mapped_names - && !SCHEME_INTP(rib->mapped_names) - && !scheme_hash_get((Scheme_Hash_Table *)rib->mapped_names, SCHEME_STX_VAL(a))) - rib = NULL; /* no need to check individual renames */ - else - rib = rib->next; /* First rib record has no rename */ - } - } else - rib = NULL; - } - } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(wraps))) { - rib_delim = WRAP_POS_FIRST(wraps); - if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) - rib_delim = scheme_false; - did_rib = NULL; - } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { - EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); - did_rib = NULL; - } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) { - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps); - - EXPLAIN(fprintf(stderr, "%d forwarding table...\n", depth)); - - did_rib = NULL; - - if (!ht->count - /* Table isn't finished if 5 is mapped to a limit: */ - || scheme_hash_get(ht, scheme_make_integer(5))) { - fill_chain_cache(wraps.l); - } - - if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) { - EXPLAIN(fprintf(stderr, "%d forwarded\n", depth)); - set_wraps_to_skip(ht, &wraps); - - continue; /* <<<<< ------ */ - } - } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { - if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { - /* Doesn't match pruned-to sym; already produce #f */ - return scheme_false; - } - } - - if (!rib) - WRAP_POS_INC(wraps); - } -} - -static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, - Scheme_Hash_Table *free_id_recur) - /* Gets a module source name under the assumption that the identifier - is not lexically renamed. This is used as a quick pre-test for - free-identifier=?. We do have to look at lexical renames to check for - equivalences installed on detection of make-rename-transformer, but at least - we can normally cache the result. */ -{ - WRAP_POS wraps; - Scheme_Object *result, *result_from; - int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0; - int no_lexical = !free_id_recur; - Scheme_Object *phase = orig_phase; - Scheme_Object *bdg = NULL, *floating = NULL; - - if (!free_id_recur - && SAME_OBJ(phase, scheme_make_integer(0)) - && ((Scheme_Stx *)a)->u.modinfo_cache) - return ((Scheme_Stx *)a)->u.modinfo_cache; - - WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); - - result = NULL; - - while (1) { - if (WRAP_POS_END_P(wraps)) { - int can_cache = (sealed >= STX_SEAL_ALL); - - if (result) - can_cache = (sealed >= STX_SEAL_BOUND); /* If it becomes bound, it can't become unbound. */ - - if (!result) - result = SCHEME_STX_VAL(a); - - if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur) - ((Scheme_Stx *)a)->u.modinfo_cache = result; - - return result; - } else if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) - || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) { - Module_Renames *mrn; - - if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { - mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); - } else { - /* Extract the relevant phase, if available */ - Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps); - - if (mrns->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - if ((!is_in_module || (mrns->kind != mzMOD_RENAME_TOPLEVEL)) - && !skip_other_mods) { - if (mrns->sealed < sealed) - sealed = mrns->sealed; - } - - mrn = extract_renames(mrns, phase); - } - - if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) - && !skip_other_mods) { - if (mrn->kind != mzMOD_RENAME_TOPLEVEL) - is_in_module = 1; - - if (same_phase(phase, mrn->phase)) { - /* Module rename: */ - Scheme_Object *rename, *glob_id; - - if (mrn->sealed < sealed) - sealed = mrn->sealed; - - if (mrn->needs_unmarshal) { - /* Use resolve_env to trigger unmarshal, so that we - don't have to implement top/from shifts here: */ - resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL); - } - - if (mrn->marked_names) { - /* Resolve based on rest of wraps: */ - if (!bdg) - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); - if (SCHEME_FALSEP(bdg)) { - if (!floating_checked) { - floating = check_floating_id(a); - floating_checked = 1; - } - bdg = floating; - } - /* Remap id based on marks and rest-of-wraps resolution: */ - glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL); - - if (SCHEME_TRUEP(bdg) - && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { - /* See "Even if this module doesn't match, the lex-renamed id" in resolve_env() */ - no_lexical = 1; - } - } else - glob_id = SCHEME_STX_VAL(a); - - if (free_id_recur && mrn->free_id_renames) { - rename = scheme_hash_get(mrn->free_id_renames, glob_id); - if (rename && SCHEME_STXP(rename)) { - int sealed; - rename = extract_module_free_id_binding((Scheme_Object *)mrn, - glob_id, - rename, - &sealed, - free_id_recur); - if (!sealed) - sealed = 0; - } - } else - rename = NULL; - if (!rename) - rename = scheme_hash_get(mrn->ht, glob_id); - if (!rename && mrn->nomarshal_ht) - rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - - if (!rename) - result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL); - else { - /* match; set result: */ - if (mrn->kind == mzMOD_RENAME_MARKED) - skip_other_mods = 1; - if (SCHEME_BOXP(rename)) { - /* only happens with free_id_renames */ - rename = SCHEME_BOX_VAL(rename); - result = SCHEME_CAR(rename); - } else if (SCHEME_PAIRP(rename)) { - if (nom_mod_p(rename)) { - result = glob_id; - } else { - result = SCHEME_CDR(rename); - if (SCHEME_PAIRP(result)) - result = SCHEME_CAR(result); - } - } else - result = glob_id; - } - - result_from = WRAP_POS_FIRST(wraps); - } - } - } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps))) { - /* Phase shift */ - Scheme_Object *n, *vec; - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); - n = SCHEME_VEC_ELS(vec)[0]; - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_minus(phase, n); - } else if (!no_lexical - && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) - || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) { - /* Lexical rename */ - Scheme_Object *rename, *renamed, *renames; - Scheme_Lexical_Rib *rib; - int ri, istart, iend; - - rename = WRAP_POS_FIRST(wraps); - if (SCHEME_RIBP(rename)) { - rib = (Scheme_Lexical_Rib *)rename; - if (rib->mapped_names - && !SCHEME_INTP(rib->mapped_names) - && !scheme_hash_get((Scheme_Hash_Table *)rib->mapped_names, SCHEME_STX_VAL(a))) - rib = NULL; /* no need to check individual renames */ - else - rib = rib->next; - rename = NULL; - } else { - rib = NULL; - if (SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[0])) { - /* No free-id=? renames here. */ - rename = NULL; - } - } - - do { - if (rib) { - if (!*rib->sealed) sealed = 0; - rename = rib->rename; - rib = rib->next; - } - - if (rename) { - int c = SCHEME_RENAME_LEN(rename); - - /* Get index from hash table, if there is one: */ - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { - void *pos; - pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a)); - if (pos) { - istart = SCHEME_INT_VAL(pos); - if (istart < 0) { - /* -1 indicates multiple slots matching this name. */ - istart = 0; - iend = c; - } else - iend = istart + 1; - } else { - istart = 0; - iend = 0; - } - } else { - istart = 0; - iend = c; - } - - for (ri = istart; ri < iend; ri++) { - renamed = SCHEME_VEC_ELS(rename)[2+ri]; - if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { - /* Check for free-id mapping: */ - renames = SCHEME_VEC_ELS(rename)[2 + ri + c]; - if (SCHEME_PAIRP(renames)) { - /* Has a relevant-looking free-id mapping. - Give up on the "fast" traversal. */ - Scheme_Object *modname, *names[7]; - int rib_dep; - - names[0] = NULL; - names[1] = NULL; - names[3] = scheme_make_integer(0); - names[4] = NULL; - names[5] = NULL; - names[6] = NULL; - - modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur); - if (rib_dep) - sealed = 0; - - if (!SCHEME_FALSEP(modname) - && !SAME_OBJ(names[0], scheme_undefined)) { - result = names[0]; - } else { - result = names[1]; /* can be NULL or alternate name */ - } - - WRAP_POS_INIT_END(wraps); - rib = NULL; - break; - } - } - } - } - } while (rib); - } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { - if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { - /* Doesn't match pruned-to sym, so no binding */ - return SCHEME_STX_VAL(a); - } - } - - /* Keep looking: */ - if (!WRAP_POS_END_P(wraps)) - WRAP_POS_INC(wraps); - } -} - -int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym) -{ - Scheme_Object *bsym; - Scheme_Hash_Table *free_id_recur; - - if (!a || !b) - return (a == b); - - if (SCHEME_STXP(b)) { - if (!asym) - free_id_recur = make_recur_table(); - else - free_id_recur = NULL; - bsym = get_module_src_name(b, phase, free_id_recur); - if (!asym) - release_recur_table(free_id_recur); - } else - bsym = b; - if (!asym) { - if (SCHEME_STXP(a)) { - free_id_recur = make_recur_table(); - asym = get_module_src_name(a, phase, free_id_recur); - release_recur_table(free_id_recur); - } else - asym = a; - } - - /* Same name? */ - if (!SAME_OBJ(asym, bsym)) - return 0; - - if ((a == asym) || (b == bsym)) - return 1; - - free_id_recur = make_recur_table(); - a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); - release_recur_table(free_id_recur); - - free_id_recur = make_recur_table(); - b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); - release_recur_table(free_id_recur); - - if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) - a = scheme_module_resolve(a, 0); - if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) - b = scheme_module_resolve(b, 0); - - /* Same binding environment? */ - return SAME_OBJ(a, b); -} - -int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase) -{ - return scheme_stx_module_eq2(a, b, scheme_make_integer(phase), NULL); -} - -Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase) -{ - if (SCHEME_STXP(a)) - return get_module_src_name(a, phase, NULL); - else - return a; -} - -Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, - Scheme_Object **a, Scheme_Object *phase, - Scheme_Object **nominal_modidx, /* how it was imported */ - Scheme_Object **nominal_name, /* imported as name */ - Scheme_Object **mod_phase, /* original defn phase level */ - Scheme_Object **src_phase_index, /* phase level of import from nominal modidx */ - Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */ - Scheme_Object **lex_env, - int *_sealed, - Scheme_Object **insp) - /* If module bound, result is module idx, and a is set to source name. - If lexically bound, result is scheme_undefined, a is unchanged, - and nominal_name is NULL or a free_id=? renamed id. - If neither, result is NULL, a is unchanged, and - and nominal_name is NULL or a free_id=? renamed id. */ -{ - if (SCHEME_STXP(*a)) { - Scheme_Object *modname, *names[7]; - int rib_dep; - - names[0] = NULL; - names[1] = NULL; - names[3] = scheme_make_integer(0); - names[4] = NULL; - names[5] = NULL; - names[6] = NULL; - - modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur); - - if (_sealed) *_sealed = !rib_dep; - - if (names[0]) { - if (SAME_OBJ(names[0], scheme_undefined)) { - if (lex_env) - *lex_env = modname; - if (nominal_name) - *nominal_name = names[1]; - return scheme_undefined; - } else { - *a = names[0]; - if (nominal_modidx) - *nominal_modidx = names[1]; - if (nominal_name) - *nominal_name = names[2]; - if (mod_phase) - *mod_phase = names[3]; - if (src_phase_index) - *src_phase_index = names[4]; - if (nominal_src_phase) - *nominal_src_phase = names[5]; - if (insp) - *insp = names[6]; - return modname; - } - } else { - if (nominal_name) *nominal_name = names[1]; - return NULL; - } - } else { - if (nominal_name) *nominal_name = NULL; - if (_sealed) *_sealed = 1; - return NULL; - } -} - -int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) -{ - Scheme_Object *m1, *m2, *skips = NULL; - - while (SCHEME_PAIRP(skip_ribs)) { - skips = add_skip_set(((Scheme_Lexical_Rib *)SCHEME_CAR(skip_ribs))->timestamp, - skips); - skip_ribs = SCHEME_CDR(skip_ribs); - } - - m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL); - m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL); - - return !SAME_OBJ(m1, m2); -} - -Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) - /* Returns either false, a lexical-rename symbol, or void for "floating" */ -{ - if (SCHEME_STXP(a)) { - Scheme_Object *r; - - r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL); - - if (SCHEME_FALSEP(r)) - r = check_floating_id(a); - - if (r) - return r; - } - return scheme_false; -} - -int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase) - /* If uid is given, it's the environment for b. */ -{ - Scheme_Object *asym, *bsym, *ae, *be; - - if (!a || !b) - return (a == b); - - if (SCHEME_STXP(a)) - asym = SCHEME_STX_VAL(a); - else - asym = a; - if (SCHEME_STXP(b)) - bsym = SCHEME_STX_VAL(b); - else - bsym = b; - - /* Same name? */ - if (!SAME_OBJ(asym, bsym)) - return 0; - - ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); - /* No need to module_resolve ae, because we ignored module renamings. */ - - if (uid) - be = uid; - else { - be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); - /* No need to module_resolve be, because we ignored module renamings. */ - } - - /* Same binding environment? */ - if (!SAME_OBJ(ae, be)) - return 0; - - /* Same marks? (If not lexically bound, ignore mark barriers.) */ - if (!uid) { - WRAP_POS aw; - WRAP_POS bw; - WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); - WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps); - if (!same_marks(&aw, &bw, ae)) - return 0; - } - - return 1; -} - -int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) -{ - return scheme_stx_env_bound_eq(a, b, NULL, phase); -} - -#if EXPLAIN_RESOLVE -Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) -{ - scheme_explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL); - --scheme_explain_resolves; - return a; -} -#endif - -Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source) -{ - /* Inspect the wraps to look for a self-modidx shift: */ - WRAP_POS w; - Scheme_Object *srcmod = scheme_false, *chain_from = NULL, *er; - Scheme_Hash_Table *export_registry = NULL; - - WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); - - while (!WRAP_POS_END_P(w)) { - if (SCHEME_BOXP(WRAP_POS_FIRST(w))) { - /* Phase shift: */ - Scheme_Object *vec, *dest, *src; - - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(w)); - - src = SCHEME_VEC_ELS(vec)[1]; - dest = SCHEME_VEC_ELS(vec)[2]; - - /* If src is #f, shift is just for phase; no redirection */ - if (!SCHEME_FALSEP(src)) { - - if (!chain_from) { - srcmod = dest; - } else if (!SAME_OBJ(chain_from, dest)) { - srcmod = scheme_modidx_shift(dest, - chain_from, - srcmod); - } - - chain_from = src; - - if (!export_registry) { - er = SCHEME_VEC_ELS(vec)[3]; - if (SCHEME_TRUEP(er)) - export_registry = (Scheme_Hash_Table *)er; - } - } - } - - WRAP_POS_INC(w); - } - - if (SCHEME_TRUEP(srcmod)) { - if (resolve) { - srcmod = scheme_module_resolve(srcmod, 0); - if (export_registry && source) { - er = scheme_hash_get(export_registry, srcmod); - if (er) - srcmod = ((Scheme_Module_Exports *)er)->modsrc; - } - srcmod = SCHEME_PTR_VAL(srcmod); - } - } - - return srcmod; -} - -int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx) -{ - /* Inspect the wraps to look for a binding: */ - WRAP_POS w; - - WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); - - while (!WRAP_POS_END_P(w)) { - if (SCHEME_RENAMESP(WRAP_POS_FIRST(w))) { - /* Module rename. For simplicity, we look at all renames, even - if they're in the wrong phase, or for the wrong module, - etc. */ - Module_Renames *mrn = (Module_Renames *)WRAP_POS_FIRST(w); - - if (scheme_tl_id_is_sym_used(mrn->marked_names, sym)) - return 1; - } else if (SCHEME_RENAMES_SETP(WRAP_POS_FIRST(w))) { - Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(w); - int i; - - if (mrns->rt && scheme_tl_id_is_sym_used(mrns->rt->marked_names, sym)) - return 1; - if (mrns->et && scheme_tl_id_is_sym_used(mrns->et->marked_names, sym)) - return 1; - - if (mrns->other_phases) { - for (i = 0; i < mrns->other_phases->size; i++) { - if (mrns->other_phases->vals[i]) - scheme_tl_id_is_sym_used(((Module_Renames *)mrns->other_phases->vals[i])->marked_names, - sym); - } - } - } - WRAP_POS_INC(w); - } - - return 0; -} - -int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *id_certs, - Scheme_Object *than_id, Scheme_Object *than_id_certs) - /* There's a good chance that certs is an extension of than_certs. */ -{ - int i, j; - Scheme_Cert *certs, *t_certs; - Scheme_Hash_Table *ht, *t_ht = NULL; - - if ((!id_certs || SAME_OBJ(id_certs, than_id_certs)) - && !ACTIVE_CERTS((Scheme_Stx *)id)) - return 0; - - if (id_marks_ht) { - ht = id_marks_ht; - id_marks_ht = NULL; - } else - ht = scheme_make_hash_table(SCHEME_hash_ptr); - add_all_marks(((Scheme_Stx *)id)->wraps, ht); - - for (i = 0; i < 2; i++) { - if (i) - certs = ACTIVE_CERTS((Scheme_Stx *)id); - else - certs = (Scheme_Cert *)id_certs; - while (certs && !SAME_OBJ(certs, (Scheme_Cert *)than_id_certs)) { - if (scheme_hash_get(ht, certs->mark)) { - /* Found a relevant certificate in id */ - if (!t_ht) { - if (than_id_marks_ht) { - t_ht = than_id_marks_ht; - than_id_marks_ht = NULL; - } else - t_ht = scheme_make_hash_table(SCHEME_hash_ptr); - add_all_marks(((Scheme_Stx *)than_id)->wraps, t_ht); - } - if (scheme_hash_get(t_ht, certs->mark)) { - /* than_id has the same mark */ - for (j = 0; j < 2; j++) { - if (j) - t_certs = ACTIVE_CERTS((Scheme_Stx *)than_id); - else - t_certs = (Scheme_Cert *)than_id_certs; - while (t_certs) { - if (SAME_OBJ(t_certs->mark, certs->mark)) - break; - t_certs = t_certs->next; - } - if (t_certs) - break; - } - if (j == 2) { - scheme_reset_hash_table(ht, NULL); - id_marks_ht = ht; - scheme_reset_hash_table(t_ht, NULL); - than_id_marks_ht = t_ht; - return 1; - } - } - } - certs = certs->next; - } - } - - scheme_reset_hash_table(ht, NULL); - id_marks_ht = ht; - if (t_ht) { - scheme_reset_hash_table(t_ht, NULL); - than_id_marks_ht = t_ht; - } - - return 0; -} - -Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to, - Scheme_Object *uid) -{ - WRAP_POS aw; - WRAP_POS bw; - - WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); - WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps); - - if (!same_marks(&aw, &bw, scheme_false)) { - Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps; - if (uid) { - /* Add a rename record: */ - Scheme_Object *rn; - rn = scheme_make_rename(uid, 1); - scheme_set_rename(rn, 0, relative_to); - wraps = scheme_make_pair(rn, wraps); - } - - { - Scheme_Stx *stx = (Scheme_Stx *)a; - Scheme_Object *certs; - certs = stx->certs; - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = wraps; - stx->certs = certs; - a = (Scheme_Object *)stx; - } - } - - return a; -} - -/*========================================================================*/ -/* stx and lists */ -/*========================================================================*/ - -int scheme_stx_list_length(Scheme_Object *list) -{ - int len; - - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - len = 0; - while (!SCHEME_NULLP(list)) { - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - if (SCHEME_PAIRP(list)) { - len++; - list = SCHEME_CDR(list); - } else { - if (!SCHEME_NULLP(list)) - len++; - break; - } - } - - return len; -} - -int scheme_stx_proper_list_length(Scheme_Object *list) -{ - int len; - Scheme_Object *turtle; - - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - len = 0; - turtle = list; - while (SCHEME_PAIRP(list)) { - len++; - - list = SCHEME_CDR(list); - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - if (!SCHEME_PAIRP(list)) - break; - len++; - list = SCHEME_CDR(list); - if (SCHEME_STXP(list)) - list = SCHEME_STX_VAL(list); - - if (SAME_OBJ(turtle, list)) - break; - - turtle = SCHEME_CDR(turtle); - if (SCHEME_STXP(turtle)) - turtle = SCHEME_STX_VAL(turtle); - - } - - if (SCHEME_NULLP(list)) - return len; - - return -1; -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *flatten_syntax_list_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *l = (Scheme_Object *)p->ku.k.p1; - int *r = (int *)p->ku.k.p2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - - return scheme_flatten_syntax_list(l, r); -} -#endif - -Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) -{ - Scheme_Object *l = lst, *lflat, *first, *last; - - /* Check whether the list ends in a null: */ - while (SCHEME_PAIRP(l)) { - l = SCHEME_CDR(l); - } - - if (SCHEME_NULLP(l)) { - /* Yes. We're done: */ - if (islist) - *islist = 1; - return lst; - } - - if (islist) - *islist = 0; - - lflat = NULL; - - /* Is it a syntax object, possibly with a list? */ - if (SCHEME_STXP(l)) { - l = scheme_stx_content(l); - if (SCHEME_NULLP(l) || SCHEME_PAIRP(l)) { - int lislist; - - lflat = NULL; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - int *r; - - r = (int *)scheme_malloc_atomic(sizeof(int)); - - p->ku.k.p1 = (void *)l; - p->ku.k.p2 = (void *)r; - - lflat = scheme_handle_stack_overflow(flatten_syntax_list_k); - - lislist = *r; - } - } -#endif - - if (!lflat) - lflat = scheme_flatten_syntax_list(l, &lislist); - - if (!lislist) { - /* Not a list. Can't flatten this one. */ - return lst; - } - } else { - /* Not a syntax list. No chance of flattening. */ - return lst; - } - } else { - /* No. No chance of flattening, then. */ - return lst; - } - - /* Need to flatten, end with lflat */ - - if (islist) - *islist = 1; - - first = last = NULL; - for (l = lst; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { - Scheme_Object *p; - p = scheme_make_pair(SCHEME_CAR(l), scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - - if (last) - SCHEME_CDR(last) = lflat; - else - first = lflat; - - return first; -} - -/*========================================================================*/ -/* wraps->datum */ -/*========================================================================*/ - -/* Used for marshaling syntax objects. Note that we build a reverse - list for wraps. (Unmarshaler will reverse it back.) - - The wraps->datum tools are also used to simplify syntax object (to - minimize the occupied space among a set of objects). */ - -#define EXPLAIN_SIMP 0 -#if EXPLAIN_SIMP -#define EXPLAIN_S(x) if (explain_simp) x -static int explain_simp = 0; -static void print_skips(Scheme_Object *skips) -{ - while (skips) { - fprintf(stderr, " skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL)); - skips = SCHEME_CDR(skips); - } -} -#else -#define EXPLAIN_S(x) /* empty */ -#endif - -static Scheme_Object *extract_free_id_info(Scheme_Object *id) -{ - Scheme_Object *bind; - Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name, *nom2; - Scheme_Object *mod_phase; - Scheme_Object *src_phase_index; - Scheme_Object *nominal_src_phase; - Scheme_Object *lex_env = NULL; - Scheme_Object *vec, *phase, *insp; - Scheme_Hash_Table *free_id_recur; - - phase = SCHEME_CDR(id); - id = SCHEME_CAR(id); - - nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); - - free_id_recur = make_recur_table(); - bind = scheme_stx_module_name(free_id_recur, - &id, phase, &nominal_modidx, &nominal_name, - &mod_phase, &src_phase_index, &nominal_src_phase, - &lex_env, NULL, &insp); - release_recur_table(free_id_recur); - - if (SCHEME_SYMBOLP(nom2)) - nominal_name = nom2; - if (!nominal_name) - nominal_name = SCHEME_STX_VAL(id); - - if (!bind) - return CONS(nominal_name, scheme_false); - else if (SAME_OBJ(bind, scheme_undefined)) - return CONS(nominal_name, lex_env); - else { - vec = scheme_make_vector(8, NULL); - vec->type = scheme_free_id_info_type; - SCHEME_VEC_ELS(vec)[0] = bind; - SCHEME_VEC_ELS(vec)[1] = id; - SCHEME_VEC_ELS(vec)[2] = nominal_modidx; - SCHEME_VEC_ELS(vec)[3] = nominal_name; - SCHEME_VEC_ELS(vec)[4] = mod_phase; - SCHEME_VEC_ELS(vec)[5] = src_phase_index; - SCHEME_VEC_ELS(vec)[6] = nominal_src_phase; - SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false); - return vec; - } -} - -static int not_in_rename(Scheme_Object *constrain_to_syms, Scheme_Object *rename) -{ - int istart, iend, ri; - Scheme_Object *renamed, *s; - - while (SCHEME_PAIRP(constrain_to_syms)) { - - s = SCHEME_CAR(constrain_to_syms); - extract_lex_range(rename, s, &istart, &iend); - - for (ri = istart; ri < iend; ri++) { - renamed = SCHEME_VEC_ELS(rename)[2+ri]; - if (SAME_OBJ(renamed, s)) - return 0; - } - - constrain_to_syms = SCHEME_CDR(constrain_to_syms); - } - - return 1; -} - -static int not_in_rib(Scheme_Object *constrain_to_syms, Scheme_Lexical_Rib *rib) -{ - for (rib = rib->next; rib; rib = rib->next) { - if (!not_in_rename(constrain_to_syms, rib->rename)) - return 0; - } - return 1; -} - -#define EXPLAIN_R(x) /* empty */ - -static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache, - Scheme_Object *stx_datum) -{ - WRAP_POS w, prev, w2; - Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs, *prev_prec_ribs; - Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false, *constrain_to_syms = NULL; - Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl; - Scheme_Lexical_Rib *did_rib = NULL; - Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; - int copy_on_write, no_rib_mutation = 1, rib_count = 0; - intptr_t size, vsize, psize, i, j, pos; - - /* Although it makes no sense to simplify the rename table itself, - we can simplify it in the context of a particular wrap suffix. - (But don't mutate the wrap list, because that will stomp on - tables that might be needed by a propoagation.) - - A lex_cache maps wrap starts within `w' to lists of simplified - tables. This helps avoid re-simplifying when the result is - clearly going to be the same. A lex_cache is read and modified by - this function, only. - - In addition to depending on the rest of the wraps, a resolved - binding can depend on preceding wraps due to rib skipping. For - now, simplifications that depend on preceding wraps are not - cached (though individual computed renamings are cached to save - space). - - The simplification stragegy mostly works inside out: since later - renames depend on earlier renames, we simplify the earlier ones - first, and then collapse to a flattened rename while working - outward. This also lets us track shared tails in some common - cases. - - A catch with the inside-out approach has to do with ribs (again). - Preceding ribs determine the recur_skip_ribs set, so we can - simply track that as we recur into the wraps initially to build - our worklist. However, whether we process a rib at all (on the - way out in the second pass) for a given id depends on whether any - preceding instance of the same rib (i.e., further out) matches - the symbol and marks. So, we have to compute that summary as we - go in. */ - - if (SCHEME_SYMBOLP(stx_datum)) { - /* Search for prunings */ - WRAP_POS_INIT(w, wraps); - old_key = NULL; - prec_ribs = NULL; - while (!WRAP_POS_END_P(w)) { - if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) - || SCHEME_RIBP(WRAP_POS_FIRST(w))) { - /* Lexical rename --- maybe an already-simplified point */ - key = WRAP_POS_KEY(w); - if (!SAME_OBJ(key, old_key)) { - v = scheme_hash_get(lex_cache, key); - if (v && SCHEME_HASHTP(v)) { - v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); - } else if (prec_ribs) - v = NULL; - } else - v = NULL; - old_key = key; - - if (v) { - /* Tables here are already simplified. */ - break; - } - - if (SCHEME_RIBP(WRAP_POS_FIRST(w))) { - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(w); - if (!nonempty_rib(rib)) - prec_ribs = add_skip_set(rib->timestamp, prec_ribs); - } - } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(w))) { - v = SCHEME_BOX_VAL(WRAP_POS_FIRST(w)); - if (is_member(stx_datum, v)) { - if (!constrain_to_syms) - constrain_to_syms = v; - else { - v2 = scheme_null; - while (SCHEME_PAIRP(v)) { - if (is_member(SCHEME_CAR(v), constrain_to_syms)) - v2 = scheme_make_pair(SCHEME_CAR(v), v2); - v = SCHEME_CDR(v); - } - constrain_to_syms = v2; - } - } else - constrain_to_syms = scheme_null; - } - WRAP_POS_INC(w); - } - } - - WRAP_POS_INIT(w, wraps); - WRAP_POS_INIT_END(prev); - - old_key = NULL; - prec_ribs = NULL; - - v2l = scheme_null; - v2rdl = NULL; - - EXPLAIN_S(fprintf(stderr, "[in simplify]\n")); - - EXPLAIN_R(printf("Simplifying %p\n", lex_cache)); - - while (!WRAP_POS_END_P(w)) { - if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) - || SCHEME_RIBP(WRAP_POS_FIRST(w))) { - /* Lexical rename */ - key = WRAP_POS_KEY(w); - EXPLAIN_R(printf(" key %p\n", key)); - if (!SAME_OBJ(key, old_key)) { - v = scheme_hash_get(lex_cache, key); - if (v && SCHEME_HASHTP(v)) { - v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); - } else if (prec_ribs) - v = NULL; - } else - v = NULL; - old_key = key; - prev_prec_ribs = prec_ribs; - prev_skip_ribs_ht = skip_ribs_ht; - - if (v) { - /* Tables here are already simplified. */ - v2l = v; /* build on simplify chain extracted from cache */ - end_mutable = v2l; - /* No non-simplified table can follow a simplified one */ - break; - } else { - int add = 0, skip_this = 0; - - v = WRAP_POS_FIRST(w); - if (SCHEME_RIBP(v)) { - /* A rib certainly isn't simplified yet. */ - Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; - no_rib_mutation = 0; - add = 1; - if (!*rib->sealed) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } - if (SAME_OBJ(did_rib, rib) - || !nonempty_rib(rib) - || (constrain_to_syms && !not_in_rib(constrain_to_syms, rib))) { - skip_this = 1; - if (!nonempty_rib(rib)) - prec_ribs = add_skip_set(rib->timestamp, prec_ribs); - EXPLAIN_S(fprintf(stderr, " to skip %p=%s\n", rib, - scheme_write_to_string(rib->timestamp, NULL))); - } else { - rib_count++; - did_rib = rib; - prec_ribs = add_skip_set(rib->timestamp, prec_ribs); - - EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, - scheme_write_to_string(rib->timestamp, NULL))); - EXPLAIN_S(print_skips(prec_ribs)); - - copy_on_write = 1; - - EXPLAIN_R(printf(" rib %p\n", rib->timestamp)); - - /* Compute, per id, whether to skip later instances of rib: */ - for (rib = rib->next; rib; rib = rib->next) { - vsize = SCHEME_RENAME_LEN(rib->rename); - for (i = 0; i < vsize; i++) { - stx = SCHEME_VEC_ELS(rib->rename)[2+i]; - - EXPLAIN_S(fprintf(stderr, " skip? %s %p=%s %s\n", - scheme_write_to_string(SCHEME_STX_VAL(stx), NULL), - rib, - scheme_write_to_string(rib->timestamp, NULL), - scheme_write_to_string(SCHEME_VEC_ELS(rib->rename)[0], NULL))); - - /* already skipped? */ - if ((!constrain_to_syms || is_member(SCHEME_STX_VAL(stx), constrain_to_syms)) - && (!skip_ribs_ht - || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp)))) { - /* No. Should we skip? */ - Scheme_Object *other_env; - other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; - other_env = filter_cached_env(other_env, prec_ribs); - if (SCHEME_VOIDP(other_env)) { - int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); - if (rib_dep) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } - { - Scheme_Object *e; - e = extend_cached_env(SCHEME_VEC_ELS(rib->rename)[2+vsize+i], other_env, prec_ribs, 0); - SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = e; - } - } - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (same_marks(&w2, &w, other_env)) { - /* yes, skip */ - EXPLAIN_S(fprintf(stderr, " skip! %s\n", - scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); - if (!skip_ribs_ht) - skip_ribs_ht = scheme_make_hash_table_equal(); - else if (copy_on_write) - skip_ribs_ht = scheme_clone_hash_table(skip_ribs_ht); - copy_on_write = 0; - scheme_hash_set(skip_ribs_ht, - scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp), - scheme_true); - } - } else { - EXPLAIN_S(fprintf(stderr, " already skipped %s\n", - scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); - } - } - } - } - } else { - /* Need to simplify this vector? */ - if (SCHEME_VEC_SIZE(v) == 1) - v = SCHEME_VEC_ELS(v)[0]; - if ((SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ - && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2])) { - add = 1; - - if (constrain_to_syms) { - /* Maybe pruned so that we don't need to resolve: */ - if (not_in_rename(constrain_to_syms, v)) - skip_this = 1; - } - } - EXPLAIN_R(printf(" lex reset\n")); - did_rib = NULL; - } - - if (add) { - if (skip_this) { - ribs_stack = scheme_make_pair(scheme_false, ribs_stack); - } else { - ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, - scheme_make_pair((Scheme_Object *)prev_skip_ribs_ht, - rib_delim)), - ribs_stack); - } - - /* Need to simplify, but do deepest first: */ - if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_VEC_ELS(SCHEME_CAR(stack))[0], key)) { - v = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(v)[0] = key; - SCHEME_VEC_ELS(v)[1] = prev_prec_ribs; - stack = CONS(v, stack); - } - } else { - /* This is already simplified. Remember it and stop, because - no non-simplified table can follow a simplified one. */ - WRAP_POS_COPY(prev, w); - break; - } - } - } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(w))) { - rib_delim = WRAP_POS_FIRST(w); - if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) - rib_delim = scheme_false; - if (rib_count > 1) { - EXPLAIN_R(if (did_rib) printf(" reset delim %d\n", rib_count)); - did_rib = NULL; - } - rib_count = 0; - } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(w))) { - v = WRAP_POS_FIRST(w); - WRAP_POS_COPY(w2, w); - WRAP_POS_INC(w2); - if (!WRAP_POS_END_P(w2) && SAME_OBJ(v, WRAP_POS_FIRST(w2))) { - WRAP_POS_INC(w); - } else { - EXPLAIN_R(printf(" reset by mark\n")); - did_rib = NULL; - } - } else { - EXPLAIN_R(if (did_rib) printf(" reset %d\n", SCHEME_TYPE(WRAP_POS_FIRST(w)))); - did_rib = NULL; - } - - WRAP_POS_INC(w); - } - - EXPLAIN_R(printf(" ... phase2\n")); - - while (!SCHEME_NULLP(stack)) { - key = SCHEME_CAR(stack); - prev_prec_ribs = SCHEME_VEC_ELS(key)[1]; - key = SCHEME_VEC_ELS(key)[0]; - - WRAP_POS_REVINIT(w, key); - - while (!WRAP_POS_REVEND_P(w)) { - v = WRAP_POS_FIRST(w); - - if (SCHEME_RIBP(v) - || (SCHEME_VECTORP(v) - && (SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ - && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) { - /* This is the place to simplify: */ - Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL; - Scheme_Object *local_ribs; - int ii, vvsize, done_rib_pos = 0; - - rib_delim = scheme_false; - - if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) { - EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, - scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); - ribs_stack = SCHEME_CDR(ribs_stack); - vsize = 0; - local_ribs = NULL; - } else { - rib_delim = SCHEME_CAR(ribs_stack); - prec_ribs = SCHEME_CAR(rib_delim); - rib_delim = SCHEME_CDR(rib_delim); - skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CAR(rib_delim); - rib_delim = SCHEME_CDR(rib_delim); - ribs_stack = SCHEME_CDR(ribs_stack); - - if (SCHEME_RIBP(v)) { - init_rib = (Scheme_Lexical_Rib *)v; - EXPLAIN_S(fprintf(stderr, " up rib %p=%s\n", init_rib, - scheme_write_to_string(init_rib->timestamp, NULL))); - EXPLAIN_S(print_skips(prec_ribs)); - rib = init_rib->next; - vsize = 0; - local_ribs = NULL; - while (rib) { - /* We need to process the renamings in reverse order: */ - local_ribs = scheme_make_raw_pair((Scheme_Object *)rib, local_ribs); - - vsize += SCHEME_RENAME_LEN(rib->rename); - rib = rib->next; - } - if (local_ribs) { - rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); - local_ribs = SCHEME_CDR(local_ribs); - } - } else { - vsize = SCHEME_RENAME_LEN(v); - local_ribs = NULL; - } - } - - /* Initial size; may shrink: */ - size = vsize; - - v2 = scheme_make_vector(2 + (2 * size), NULL); - v2_rib_delims = MALLOC_N(Scheme_Object *, size); - - pos = 0; /* counter for used slots */ - - /* Local vector (different from i when we have a rib) */ - ii = 0; - vvsize = vsize; - - for (i = 0; i < vsize; i++) { - if (rib) { - v = rib->rename; - vvsize = SCHEME_RENAME_LEN(v); - while (ii >= vvsize) { - ii = 0; - done_rib_pos = pos; - rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); - local_ribs = SCHEME_CDR(local_ribs); - v = rib->rename; - vvsize = SCHEME_RENAME_LEN(v); - } - } - stx = SCHEME_VEC_ELS(v)[2+ii]; - name = SCHEME_STX_VAL(stx); - SCHEME_VEC_ELS(v2)[2+pos] = name; - - if ((!constrain_to_syms || is_member(name, constrain_to_syms)) - && (!rib - || !skip_ribs_ht - || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp)))) { - /* Either this name is in prev, in which case the answer - must match this rename's target, or this rename's - answer applies. */ - Scheme_Object *ok = NULL, *ok_replace = NULL, **ok_replace_rd = NULL; - int ok_replace_index = 0, ok_replace_rd_index = 0; - Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env; - - if (rib) { - EXPLAIN_S(fprintf(stderr, " resolve %s %s (%d)\n", - scheme_write_to_string(name, NULL), - scheme_write_to_string(rib->timestamp, NULL), - done_rib_pos)); - } - - other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; - if (SCHEME_PAIRP(other_env)) - free_id_rename = extract_free_id_info(SCHEME_CDR(other_env)); - else - free_id_rename = NULL; - other_env = filter_cached_env(other_env, prec_ribs); - if (SCHEME_VOIDP(other_env)) { - int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); - if (rib_dep) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } - if (!prec_ribs) { - if (free_id_rename) - ok = CONS(other_env, free_id_rename); - else - ok = other_env; - SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; - ok = NULL; - } else { - ok = extend_cached_env(SCHEME_VEC_ELS(v)[2+vvsize+ii], other_env, prec_ribs, 0); - SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; - ok = NULL; - } - } - - if (!WRAP_POS_END_P(prev) - || SCHEME_PAIRP(v2l)) { - WRAP_POS w3; - Scheme_Object *vp, **vrdp; - - /* Check marks (now that we have the correct barriers). */ - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (!same_marks(&w2, &w, other_env)) { - other_env = NULL; - } - - if (other_env) { - /* A simplified table needs to have the final answer, so - fold conversions from the rest of the wraps. In the case - of ribs, the "rest" can include earlier rib renamings. - Otherwise, check simplications accumulated in v2l (possibly from a - previously simplified tail in the same cache). Finally, - try prev (from a previously simplified tail in an earlier - round of simplifying). */ - int rib_found = 0; - if (done_rib_pos) { - for (j = 0; j < done_rib_pos; j++) { - if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) { - rib_found = 1; - prev_env = SCHEME_VEC_ELS(v2)[2+size+j]; - orig_prev_env = prev_env; - if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); - if (SAME_OBJ(prev_env, other_env)) { - if (SCHEME_FALSEP(rib_delim) - || SAME_OBJ(v2_rib_delims[j], rib_delim) - || !is_in_rib_delim(prev_env, rib_delim)) { - ok = SCHEME_VEC_ELS(v)[0]; - ok_replace = v2; - ok_replace_index = 2 + size + j; - ok_replace_rd = v2_rib_delims; - if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) - free_id_rename = SCHEME_CDR(orig_prev_env); - } - } else { - EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); - ok = NULL; - } - break; - } - } - } - if (!rib_found) { - int passed_mutable = 0; - WRAP_POS_COPY(w3, prev); - svl = v2l; - svrdl = v2rdl; - for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) { - if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1; - if (SCHEME_PAIRP(svl)) { - vp = SCHEME_CAR(svl); - if (svrdl) - vrdp = (Scheme_Object **)SCHEME_CAR(svrdl); - else - vrdp = NULL; - } else { - vp = WRAP_POS_FIRST(w3); - vrdp = NULL; - } - if (SCHEME_VECTORP(vp)) { - psize = SCHEME_RENAME_LEN(vp); - for (j = 0; j < psize; j++) { - if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) { - prev_env = SCHEME_VEC_ELS(vp)[2+psize+j]; - orig_prev_env = prev_env; - if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); - if (SAME_OBJ(prev_env, other_env) - && (SCHEME_FALSEP(rib_delim) - || (vrdp && (SAME_OBJ(vrdp[j], rib_delim))) - || !is_in_rib_delim(prev_env, rib_delim))) { - ok = SCHEME_VEC_ELS(v)[0]; - if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) - free_id_rename = SCHEME_CDR(orig_prev_env); - } else { - EXPLAIN_S(fprintf(stderr, - " not matching deeper %s\n", - scheme_write_to_string(other_env, NULL))); - ok = NULL; - /* Alternate time/space tradeoff: could be - SCHEME_VEC_ELS(vp)[2+psize+j], - which is the value from prev */ - } - if (ok && SCHEME_PAIRP(svl) && !passed_mutable - && (SCHEME_FALSEP(rib_delim) || vrdp)) { - /* Can overwrite old map, instead - of adding a new one. */ - ok_replace = vp; - ok_replace_index = 2 + psize + j; - ok_replace_rd = vrdp; - ok_replace_rd_index = j; - } - break; - } - } - if (j < psize) - break; - } - if (SCHEME_PAIRP(svl)) { - svl = SCHEME_CDR(svl); - if (svrdl) svrdl = SCHEME_CDR(svrdl); - } else { - WRAP_POS_INC(w3); - } - } - if (WRAP_POS_END_P(w3) && SCHEME_NULLP(svl) && SCHEME_FALSEP(other_env)) - ok = SCHEME_VEC_ELS(v)[0]; - } - } else - ok = NULL; - } else { - if (!SCHEME_FALSEP(other_env)) { - EXPLAIN_S(fprintf(stderr, " not based on #f\n")); - ok = NULL; - } else { - WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); - if (same_marks(&w2, &w, scheme_false)) - ok = SCHEME_VEC_ELS(v)[0]; - else { - EXPLAIN_S(fprintf(stderr, " not matching marks\n")); - ok = NULL; - } - } - } - - if (ok) { - if (free_id_rename) - ok = CONS(ok, free_id_rename); - if (ok_replace) { - EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", - scheme_write_to_string(ok, NULL))); - SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok; - ok_replace_rd[ok_replace_rd_index] = rib_delim; - } else { - EXPLAIN_S(fprintf(stderr, " add mapping %s\n", - scheme_write_to_string(ok, NULL))); - SCHEME_VEC_ELS(v2)[2+size+pos] = ok; - v2_rib_delims[pos] = rib_delim; - pos++; - } - } else { - EXPLAIN_S(fprintf(stderr, " no mapping %s\n", - scheme_write_to_string(name, NULL))); - } - } else { - EXPLAIN_S(fprintf(stderr, " skip %s %s %p\n", - scheme_write_to_string(name, NULL), - scheme_write_to_string(rib->timestamp, NULL), - rib)); - } - ii++; - } - - if (!pos) - v2 = empty_simplified; - else { - if (pos != size) { - /* Shrink simplified vector */ - v = v2; - v2 = scheme_make_vector(2 + (2 * pos), NULL); - for (i = 0; i < pos; i++) { - SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; - SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; - } - } - - SCHEME_VEC_ELS(v2)[0] = scheme_false; - for (i = 0; i < pos; i++) { - if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v2)[2+pos+i])) - SCHEME_VEC_ELS(v2)[0] = scheme_true; - } - - SCHEME_VEC_ELS(v2)[1] = scheme_false; - maybe_install_rename_hash_table(v2); - - if (no_rib_mutation) { - /* Sometimes we generate the same simplified lex table, so - look for an equivalent one in the cache. */ - v = scheme_hash_get(lex_cache, scheme_true); - if (!v) { - v = (Scheme_Object *)scheme_make_hash_table_equal(); - scheme_hash_set(lex_cache, scheme_true, v); - } - svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); - if (svl) - v2 = svl; - else - scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); - } - } - - v2l = CONS(v2, v2l); - v2rdl = scheme_make_raw_pair((Scheme_Object *)v2_rib_delims, v2rdl); - } - - WRAP_POS_DEC(w); - } - - if (!constrain_to_syms) { - v = scheme_hash_get(lex_cache, key); - if (!v && !prev_prec_ribs) { - /* no dependency on ribs, so we can simply cache this result: */ - scheme_hash_set(lex_cache, key, v2l); - } else { - Scheme_Hash_Table *ht; - if (v && SCHEME_HASHTP(v)) - ht = (Scheme_Hash_Table *)v; - else { - ht = scheme_make_hash_table(SCHEME_hash_ptr); - } - if (v && !SCHEME_HASHTP(v)) - scheme_hash_set(ht, scheme_false, v); - scheme_hash_set(ht, prev_prec_ribs ? prev_prec_ribs : scheme_false, v2l); - scheme_hash_set(lex_cache, key, (Scheme_Object *)ht); - } - end_mutable = v2l; - } - - stack = SCHEME_CDR(stack); - } - - EXPLAIN_R(printf(" ... done\n")); - - return v2l; -} - -static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, - Scheme_Object *w_in, - Scheme_Marshal_Tables *mt, - Scheme_Hash_Table *rns, - int just_simplify) -{ - Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *prec_ribs = scheme_null; - WRAP_POS w; - Scheme_Hash_Table *lex_cache, *reverse_map; - int stack_size = 0, specific_to_datum = 0; - - if (!rns) - rns = mt->rns; - - if (just_simplify) { - a = scheme_hash_get(rns, w_in); - } else { - if (mt->same_map) { - a = scheme_hash_get(mt->same_map, w_in); - if (a) - w_in = a; - } - a = scheme_marshal_lookup(mt, w_in); - } - if (a) { - if (just_simplify) - return a; - else { - scheme_marshal_using_key(mt, w_in); - return a; - } - } - - WRAP_POS_INIT(w, w_in); - - stack = scheme_null; - - lex_cache = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_void); - if (!lex_cache) { - lex_cache = scheme_make_hash_table(SCHEME_hash_ptr); - scheme_hash_set(rns, scheme_void, (Scheme_Object *)lex_cache); - } - - if (!just_simplify) - stx_datum = scheme_false; - - /* Ensures that all lexical tables in w have been simplified */ - simplifies = simplify_lex_renames(w_in, lex_cache, stx_datum); - - if (mt) - scheme_marshal_push_refs(mt); - - while (!WRAP_POS_END_P(w)) { - a = WRAP_POS_FIRST(w); - old_key = WRAP_POS_KEY(w); - WRAP_POS_INC(w); - if (SCHEME_NUMBERP(a)) { - /* Mark numbers get parenthesized */ - if (!WRAP_POS_END_P(w) && SAME_OBJ(a, WRAP_POS_FIRST(w))) - WRAP_POS_INC(w); /* delete cancelled mark */ - else { - if (just_simplify) - stack = CONS(a, stack); - else - stack = CONS(CONS(a, scheme_null), stack); - stack_size++; - } - } else if (SCHEME_VECTORP(a) - || SCHEME_RIBP(a)) { - if (SCHEME_RIBP(a) || (SCHEME_VEC_SIZE(a) > 2)) { - - if (SCHEME_RIBP(a) || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[2])) { - /* a is not a simplified table; need to look it up; if - simplifies is non-null, then we already have found a list - of simplified tables for the current wrap segment. */ - if (SCHEME_RIBP(a)) { - if (nonempty_rib((Scheme_Lexical_Rib *)a)) - prec_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, prec_ribs); - } - a = SCHEME_CAR(simplifies); - /* used up one simplification: */ - simplifies = SCHEME_CDR(simplifies); - } - - /* Simplification may have left us with the null table: */ - if (SCHEME_VEC_SIZE(a) > 2) { - if (just_simplify) { - stack = CONS(a, stack); - } else { - Scheme_Object *local_key; - - local_key = scheme_marshal_lookup(mt, a); - if (local_key) { - scheme_marshal_using_key(mt, a); - a = local_key; - } else { - a = scheme_marshal_wrap_set(mt, a, a); - } - stack = CONS(a, stack); - } - stack_size++; - } - } - /* else empty simplified vector, which we drop */ - } else if (SCHEME_RIB_DELIMP(a)) { - /* simpliciation eliminates the need for rib delimiters */ - } else if (SCHEME_RENAMESP(a) - || SCHEME_RENAMES_SETP(a)) { - int which = 0; - - while (1) { - Module_Renames *mrn; - int redundant = 0; - - if (SCHEME_RENAMESP(a)) { - if (!which) { - mrn = (Module_Renames *)a; - which++; - } else - break; - } else { - /* flatten sets */ - Module_Renames_Set *s = (Module_Renames_Set *)a; - mrn = NULL; - while (!mrn - && (which - 2 < (s->other_phases - ? s->other_phases->size - : 0))) { - if (!which) - mrn = s->rt; - else if (which == 1) - mrn = s->et; - else - mrn = (Module_Renames *)s->other_phases->vals[which - 2]; - which++; - } - if (!mrn - && (which - 2 >= (s->other_phases - ? s->other_phases->size - : 0))) - break; - } - - if (mrn) { - if (mrn->kind == mzMOD_RENAME_MARKED) { - /* Not useful if there's no marked names. */ - redundant = ((mrn->sealed >= STX_SEAL_ALL) - && (!mrn->marked_names || !mrn->marked_names->count) - && (!mrn->free_id_renames || !mrn->free_id_renames->count) - && SCHEME_NULLP(mrn->shared_pes)); - if (!redundant) { - /* Otherwise, watch out for multiple instances of the same rename: */ - WRAP_POS l; - Scheme_Object *la; - - WRAP_POS_COPY(l,w); - - for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { - la = WRAP_POS_FIRST(l); - if (SAME_OBJ(a, la)) { - redundant = 1; - break; - } - } - } - } else { - /* Check for later [non]module rename at the same phase: */ - Scheme_Object *phase; - WRAP_POS l; - Scheme_Object *la; - - WRAP_POS_COPY(l,w); - - phase = mrn->phase; - - for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { - la = WRAP_POS_FIRST(l); - if (SCHEME_RENAMESP(la)) { - Module_Renames *lrn = (Module_Renames *)WRAP_POS_FIRST(l); - if ((lrn->kind == mrn->kind) - && (same_phase(lrn->phase, phase))) { - /* mrn is redundant */ - redundant = 1; - break; - } - } else if (SCHEME_RENAMES_SETP(la)) { - Module_Renames_Set *s = (Module_Renames_Set *)WRAP_POS_FIRST(l); - if ((s->kind == mrn->kind) - && extract_renames(s, phase)) { - redundant = 1; - break; - } - } else if (SCHEME_BOXP(la)) { - if (SCHEME_TRUEP(phase)) - phase = scheme_bin_minus(phase, - SCHEME_VEC_ELS(SCHEME_PTR_VAL(WRAP_POS_FIRST(l)))[0]); - } - } - } - - if (!redundant) { - if (just_simplify) { - stack = CONS((Scheme_Object *)mrn, stack); - } else { - if (mrn->free_id_renames) { - /* resolve all renamings */ - int i; - Scheme_Object *b; - for (i = mrn->free_id_renames->size; i--; ) { - if (mrn->free_id_renames->vals[i]) { - if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { - int sealed; - Scheme_Hash_Table *free_id_recur; - - free_id_recur = make_recur_table(); - b = extract_module_free_id_binding((Scheme_Object *)mrn, - mrn->free_id_renames->keys[i], - mrn->free_id_renames->vals[i], - &sealed, - free_id_recur); - release_recur_table(free_id_recur); - if (!sealed) { - scheme_signal_error("write: unsealed local-definition or module context" - " found in syntax object"); - } - scheme_hash_set(mrn->free_id_renames, mrn->free_id_renames->keys[i], b); - } - } - } - } - - if (mrn->kind == mzMOD_RENAME_TOPLEVEL) { - if (same_phase(mrn->phase, scheme_make_integer(0))) - stack = CONS(scheme_true, stack); - else - stack = CONS(scheme_false, stack); - } else { - Scheme_Object *local_key; - - local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn); - if (!local_key) { - /* Convert hash table to vector, etc.: */ - int i, j, count = 0; - Scheme_Hash_Table *ht; - Scheme_Object *l, *fil; - - ht = mrn->ht; - count = ht->count; - l = scheme_make_vector(count * 2, NULL); - for (i = ht->size, j = 0; i--; ) { - if (ht->vals[i]) { - SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; - fil = ht->vals[i]; - if (SCHEME_PAIRP(fil) && is_rename_inspector_info(SCHEME_CAR(fil))) { - /* use 1 or 2 to indicate inspector info */ - if (SCHEME_PAIRP(SCHEME_CAR(fil))) - fil = CONS(scheme_make_integer(2), SCHEME_CDR(fil)); - else - fil = CONS(scheme_make_integer(1), SCHEME_CDR(fil)); - } - SCHEME_VEC_ELS(l)[j++] = fil; - } - } - - ht = mrn->free_id_renames; - if (ht && ht->count) { - count = ht->count; - fil = scheme_make_vector(count * 2, NULL); - for (i = ht->size, j = 0; i--; ) { - if (ht->vals[i]) { - SCHEME_VEC_ELS(fil)[j++] = ht->keys[i]; - SCHEME_VEC_ELS(fil)[j++] = ht->vals[i]; - } - } - } else - fil = NULL; - - if (mrn->marked_names && mrn->marked_names->count) { - Scheme_Object *d = scheme_null, *p; - - for (i = mrn->marked_names->size; i--; ) { - if (mrn->marked_names->vals[i] - /* #f mapping used to store reverse-map cache: */ - && !SCHEME_FALSEP(mrn->marked_names->keys[i])) { - p = CONS(mrn->marked_names->keys[i], - mrn->marked_names->vals[i]); - d = CONS(p, d); - } - } - - if (fil) - fil = CONS(fil, d); - else - fil = d; - } else if (fil) - fil = CONS(fil, scheme_null); - else - fil = scheme_null; - - l = CONS(l, fil); - - if (SCHEME_PAIRP(mrn->unmarshal_info)) - l = CONS(mrn->unmarshal_info, l); - - l = CONS(mrn->set_identity, l); - l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l); - l = CONS(mrn->phase, l); - - local_key = scheme_marshal_lookup(mt, a); - if (local_key) - scheme_marshal_using_key(mt, a); - else { - local_key = scheme_marshal_wrap_set(mt, a, l); - } - } else { - scheme_marshal_using_key(mt, (Scheme_Object *)mrn); - } - stack = CONS(local_key, stack); - } - } - stack_size++; - } - } - } - } else if (SCHEME_SYMBOLP(a)) { - /* mark barrier */ - stack = CONS(a, stack); - stack_size++; - } else if (SCHEME_HASHTP(a)) { - /* chain-specific cache; drop it */ - } else if (SCHEME_PRUNEP(a)) { - if (SCHEME_SYMBOLP(stx_datum)) { - /* Assuming that there are lex renames later, then this chain is - specific to this wrap. */ - specific_to_datum = 1; - } - if (!just_simplify) - a = scheme_box(SCHEME_BOX_VAL(a)); - stack = CONS(a, stack); - stack_size++; - } else { - /* box, a phase shift */ - /* We used to drop a phase shift if there are no following - rename tables. However, the phase shift also identifies - the source module, which can be relevant. So, keep the - phase shift. */ - /* Need the phase shift, but drop the export table, if any: */ - Scheme_Object *local_key; - Scheme_Object *aa; - - aa = SCHEME_BOX_VAL(a); - if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3])) { - if (mt) - a = scheme_hash_get(mt->shift_map, aa); - else - a = scheme_hash_get(rns, aa); - if (!a) { - a = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0]; - SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1]; - SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2]; - SCHEME_VEC_ELS(a)[3] = scheme_false; - a = scheme_box(a); - scheme_hash_set(rns, aa, a); - } - } - - if (!just_simplify) { - local_key = scheme_marshal_lookup(mt, a); - if (local_key) { - scheme_marshal_using_key(mt, a); - a = local_key; - } else { - a = scheme_marshal_wrap_set(mt, a, a); - } - } - - stack = CONS(a, stack); - stack_size++; - } - } - - /* Double-check for equivalent list in table (after simplification): */ - if (mt && mt->pass) { - /* No need to check for later passes, since mt->same_map - covers the equivalence. */ - } else { - if (mt) { - reverse_map = mt->reverse_map; - } else { - reverse_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_undefined); - } - if (!reverse_map) { - reverse_map = scheme_make_hash_table_equal(); - if (mt) - mt->reverse_map = reverse_map; - else - scheme_hash_set(rns, scheme_undefined, (Scheme_Object *)reverse_map); - } - old_key = scheme_hash_get(reverse_map, stack); - if (old_key) { - if (just_simplify) { - return scheme_hash_get(rns, old_key); - } else { - a = scheme_marshal_lookup(mt, old_key); - scheme_marshal_using_key(mt, old_key); - if (!mt->same_map) { - Scheme_Hash_Table *same_map; - same_map = scheme_make_hash_table(SCHEME_hash_ptr); - mt->same_map = same_map; - } - scheme_hash_set(mt->same_map, w_in, old_key); - /* nevermind references that we saw when creating `stack': */ - scheme_marshal_pop_refs(mt, 0); - return a; - } - } - - if (!specific_to_datum) - scheme_hash_set(reverse_map, stack, w_in); - } - - /* Convert to a chunk if just simplifying. - (Note that we do this after looking for equivalent stacks.) */ - if (just_simplify) { - if (stack_size) { - Wrap_Chunk *wc; - int i; - wc = MALLOC_WRAP_CHUNK(stack_size); - wc->type = scheme_wrap_chunk_type; - wc->len = stack_size; - for (i = stack_size; i--; stack = SCHEME_CDR(stack)) { - wc->a[i] = SCHEME_CAR(stack); - } - stack = CONS((Scheme_Object *)wc, scheme_null); - } else - stack= scheme_null; - } - - if (mt) { - /* preserve references that we saw when creating `stack': */ - scheme_marshal_pop_refs(mt, 1); - } - - /* Remember this wrap set: */ - if (just_simplify) { - if (!specific_to_datum) - scheme_hash_set(rns, w_in, stack); - return stack; - } else { - return scheme_marshal_wrap_set(mt, w_in, stack); - } -} - -/*========================================================================*/ -/* syntax->datum */ -/*========================================================================*/ - -/* This code can convert a syntax object plus its wraps to something - writeable. In that case, the result is a : - - = (vector ) - | - = | ... - - = (cons (cons (cons ... )) ) - | (cons (cons ... null) ) - | (cons (cons #t ) ) - ; where has no boxes or vectors, and - ; is shared in all elements - = (cons (box ) ) - = (cons (vector ...) ) - = (cons ) - ; where is not a pair, vector, or box -*/ - -static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_mark, int pair_ok) -{ - /* We only share wraps for things constucted with pairs and - atomic (w.r.t. syntax) values, where there are no certificates - on any of the sub-parts. */ - Scheme_Object *v; - - if (SCHEME_PAIRP(a)) { - v = SCHEME_CAR(a); - - if (SCHEME_PAIRP(v)) { - if (pair_ok && SAME_OBJ(SCHEME_CAR(v), scheme_true)) { - /* A pair with shared wraps for its elements */ - if (get_mark) - return SCHEME_CDR(a); - else - return SCHEME_CDR(v); - } - } else if (!SCHEME_BOXP(v) && !SCHEME_VECTORP(v)) { - /* It's atomic. */ - if (get_mark) - return SCHEME_CDR(a); - else - return v; - } - } - - return NULL; -} - -static void lift_common_wraps(Scheme_Object *l, Scheme_Object *common_wraps, int cnt, int tail) -{ - Scheme_Object *a; - - while (cnt--) { - a = SCHEME_CAR(l); - a = extract_for_common_wrap(a, 0, 1); - SCHEME_CAR(l) = a; - if (cnt) - l = SCHEME_CDR(l); - } - if (tail) { - a = SCHEME_CDR(l); - a = extract_for_common_wrap(a, 0, 0); - SCHEME_CDR(l) = a; - } -} - -static Scheme_Object *record_certs(Scheme_Object *cert_marks, Scheme_Marshal_Tables *mt) -{ - Scheme_Object *v, *local_key; - - if (SCHEME_PAIRP(cert_marks)) { - v = scheme_hash_get(mt->cert_lists, cert_marks); - if (!v) { - scheme_hash_set(mt->cert_lists, cert_marks, cert_marks); - v = cert_marks; - } - - local_key = scheme_marshal_lookup(mt, v); - if (local_key) { - scheme_marshal_using_key(mt, v); - return local_key; - } else { - return scheme_marshal_wrap_set(mt, v, v); - } - } else - return scheme_null; -} - -#ifdef DO_STACK_CHECK -static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_marks, - Scheme_Marshal_Tables *mt); - -static Scheme_Object *syntax_to_datum_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p3 = NULL; - - return syntax_to_datum_inner(o, p->ku.k.i1, mt); -} -#endif - -static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, - int with_marks, - Scheme_Marshal_Tables *mt) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *v, *result, *converted_wraps = NULL; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)o; - p->ku.k.i1 = with_marks; - p->ku.k.p3 = (void *)mt; - return scheme_handle_stack_overflow(syntax_to_datum_k); - } - } -#endif - SCHEME_USE_FUEL(1); - - if (with_marks) { - /* Propagate wraps: */ - scheme_stx_content((Scheme_Object *)stx); - } - - v = stx->val; - - if (SCHEME_PAIRP(v)) { - Scheme_Object *first = NULL, *last = NULL, *p, *common_wraps = NULL; - int cnt = 0; - - while (SCHEME_PAIRP(v)) { - Scheme_Object *a; - - cnt++; - - a = syntax_to_datum_inner(SCHEME_CAR(v), with_marks, mt); - - p = CONS(a, scheme_null); - - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - v = SCHEME_CDR(v); - - if (with_marks) { - a = extract_for_common_wrap(a, 1, 1); - if (!common_wraps) { - if (a) - common_wraps = a; - else - common_wraps = scheme_false; - } else if (!a || !SAME_OBJ(common_wraps, a)) - common_wraps = scheme_false; - } - } - if (!SCHEME_NULLP(v)) { - v = syntax_to_datum_inner(v, with_marks, mt); - SCHEME_CDR(last) = v; - - if (with_marks) { - v = extract_for_common_wrap(v, 1, 0); - if (v && SAME_OBJ(common_wraps, v)) { - converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); - if (SAME_OBJ(common_wraps, converted_wraps)) - lift_common_wraps(first, common_wraps, cnt, 1); - else - common_wraps = scheme_false; - } else - common_wraps = scheme_false; - } - - if ((with_marks > 1) && SCHEME_FALSEP(common_wraps)) { - /* v is likely a pair, and v's car might be a pair, - which means that the datum->syntax part - won't be able to detect that v is a "non-pair" - terminal. Therefore, we communicate the - length before the terminal to datum->syntax: */ - first = scheme_make_pair(scheme_make_integer(cnt), first); - } - } else if (with_marks && SCHEME_TRUEP(common_wraps)) { - converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); - if (SAME_OBJ(common_wraps, converted_wraps)) - lift_common_wraps(first, common_wraps, cnt, 0); - else - common_wraps = scheme_false; - } - - if (with_marks && SCHEME_TRUEP(common_wraps)) { - first = scheme_make_pair(scheme_true, first); - } - - result = first; - } else if (SCHEME_BOXP(v)) { - v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), with_marks, mt); - result = scheme_box(v); - SCHEME_SET_IMMUTABLE(result); - } else if (SCHEME_VECTORP(v)) { - int size = SCHEME_VEC_SIZE(v), i; - Scheme_Object *r, *a; - - r = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], with_marks, mt); - SCHEME_VEC_ELS(r)[i] = a; - } - - result = r; - SCHEME_SET_IMMUTABLE(result); - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; - Scheme_Object *key, *val; - int i; - - ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - val = syntax_to_datum_inner(val, with_marks, mt); - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht, i); - } - - result = (Scheme_Object *)ht2; - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - Scheme_Object *a; - int size = s->stype->num_slots, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); - for (i = 0; i < size; i++) { - a = syntax_to_datum_inner(s->slots[i], with_marks, mt); - s->slots[i] = a; - } - - result = (Scheme_Object *)s; - } else - result = v; - - if (with_marks > 1) { - if (!converted_wraps) - converted_wraps = wraps_to_datum(stx->val, stx->wraps, mt, NULL, 0); - result = CONS(result, converted_wraps); - if (stx->certs) { - Scheme_Object *cert_marks = scheme_null, *icert_marks = scheme_null; - Scheme_Cert *certs; - - certs = ACTIVE_CERTS(stx); - while (certs) { - cert_marks = scheme_make_pair(certs->modidx, cert_marks); - cert_marks = scheme_make_pair(certs->mark, cert_marks); - certs = certs->next; - } - certs = INACTIVE_CERTS(stx); - while (certs) { - icert_marks = scheme_make_pair(certs->modidx, icert_marks); - icert_marks = scheme_make_pair(certs->mark, icert_marks); - certs = certs->next; - } - - if (SCHEME_PAIRP(cert_marks) - || SCHEME_PAIRP(icert_marks)) { - - cert_marks = record_certs(cert_marks, mt); - icert_marks = record_certs(icert_marks, mt); - - v = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(v)[0] = result; - if (!SCHEME_NULLP(icert_marks)) { - cert_marks = scheme_make_pair(cert_marks, icert_marks); - if (SCHEME_NUMBERP(SCHEME_CAR(cert_marks))) - cert_marks = scheme_make_pair(scheme_false, cert_marks); - } - SCHEME_VEC_ELS(v)[1] = cert_marks; - result = v; - } - } - } - - return result; -} - -Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks, - Scheme_Marshal_Tables *mt) -{ - Scheme_Object *v; - - if (mt) - scheme_marshal_push_refs(mt); - - v = syntax_to_datum_inner(stx, with_marks, mt); - - if (mt) { - /* A symbol+wrap combination is likely to be used multiple - times. This is a relatively minor optimization in .zo size, - since v is already fairly compact, but it also avoids - allocating extra syntax objects at load time. For consistency, - we try to reuse all combinations. */ - Scheme_Hash_Table *top_map; - Scheme_Object *key; - - top_map = mt->top_map; - if (!top_map) { - top_map = scheme_make_hash_table_equal(); - mt->top_map = top_map; - } - - key = scheme_hash_get(top_map, v); - if (key) { - scheme_marshal_pop_refs(mt, 0); - v = scheme_marshal_lookup(mt, key); - scheme_marshal_using_key(mt, key); - } else { - scheme_hash_set(top_map, stx, v); - v = scheme_marshal_wrap_set(mt, stx, v); - scheme_marshal_pop_refs(mt, 1); - } - } - - return v; -} - -/*========================================================================*/ -/* datum->wraps */ -/*========================================================================*/ - -static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Unmarshal_Tables *ut) -{ - Scheme_Object *n, *a = _a; - - if (SCHEME_INTP(a) && IS_POSMARK(a)) - a = scheme_make_integer(-SCHEME_INT_VAL(a)); - else if (!SCHEME_NUMBERP(a)) - return NULL; - else - a = scheme_intern_symbol(scheme_number_to_string(10, a)); - - /* Picked a mapping yet? */ - n = scheme_hash_get(ut->rns, a); - if (!n) { - /* Map marshaled mark to a new mark. */ - n = scheme_new_mark(); - if (!IS_POSMARK(_a)) { - /* Map negative mark to negative mark: */ - n = negate_mark(n); - } - scheme_hash_set(ut->rns, a, n); - } - - /* Really a mark? */ - if (!SCHEME_NUMBERP(n)) - return NULL; - - return n; -} - -#if 0 -# define return_NULL return (printf("%d\n", __LINE__), NULL) -#else -# define return_NULL return NULL -#endif - -static int ok_phase(Scheme_Object *o) { - return (SCHEME_INTP(o) || SCHEME_BIGNUMP(o) || SCHEME_FALSEP(o)); -} -static int ok_phase_index(Scheme_Object *o) { - return ok_phase(o); -} - -static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok, - Scheme_Unmarshal_Tables *ut) -{ - int count, i; - Scheme_Object *key, *p0, *p; - - if (!SCHEME_VECTORP(a)) return_NULL; - count = SCHEME_VEC_SIZE(a); - if (count & 0x1) return_NULL; - - for (i = 0; i < count; i+= 2) { - key = SCHEME_VEC_ELS(a)[i]; - p0 = SCHEME_VEC_ELS(a)[i+1]; - - if (!SCHEME_SYMBOLP(key)) return_NULL; - - p = p0; - if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) { - /* reconstruct inspector info */ - Scheme_Object *insp; - if (ut) - insp = scheme_get_cport_inspector(ut->rp); - else - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) { - insp = CONS(scheme_make_inspector(insp), insp); - } - p = SCHEME_CDR(p0); - p0 = CONS(insp, p); - } - - if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(p)) { - Scheme_Object *midx; - - midx = SCHEME_CAR(p); - if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) - return_NULL; - - if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { - /* Ok */ - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { - /* Ok */ - } else { - Scheme_Object *ap, *bp; - - ap = SCHEME_CDR(p); - if (!SCHEME_PAIRP(ap)) - return_NULL; - - /* mod-phase, maybe */ - if (SCHEME_INTP(SCHEME_CAR(ap))) { - bp = SCHEME_CDR(ap); - } else - bp = ap; - - /* exportname */ - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - - /* nominal_modidx_plus_phase */ - bp = SCHEME_CDR(bp); - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(ap)) { - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) - return_NULL; - ap = SCHEME_CDR(ap); - /* import_phase_plus_nominal_phase */ - if (SCHEME_PAIRP(ap)) { - if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL; - if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL; - } else if (!ok_phase_index(ap)) - return_NULL; - } else - return_NULL; - - /* nominal_exportname */ - ap = SCHEME_CDR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - } - } else if (lex_ok) { - Scheme_Object *ap; - if (!SCHEME_BOXP(p)) - return_NULL; - ap = SCHEME_BOX_VAL(p); - if (!SCHEME_PAIRP(ap)) - return_NULL; - if (!SCHEME_SYMBOLP(SCHEME_CAR(ap))) - return_NULL; - ap = SCHEME_CDR(ap); - if (!SCHEME_SYMBOLP(ap) && !SCHEME_FALSEP(ap)) - return_NULL; - } else - return_NULL; - - scheme_hash_set(ht, key, p0); - } - - return scheme_true; -} - -static Scheme_Object *datum_to_wraps(Scheme_Object *w, - Scheme_Unmarshal_Tables *ut) -{ - Scheme_Object *a, *wraps_key, *local_key; - int stack_size, decoded; - Wrap_Chunk *wc; - - /* ut->rns maps numbers (table indices) to renaming tables, and negative - numbers (negated fixnum marks) and symbols (interned marks) to marks.*/ - - /* This function has to be defensive, since `w' can originate in - untrusted .zo bytecodes. Return NULL for bad wraps. */ - - if (SCHEME_INTP(w)) { - wraps_key = w; - w = scheme_unmarshal_wrap_get(ut, wraps_key, &decoded); - if (decoded && (!w || !SCHEME_LISTP(w))) /* list => a wrap, as opposed to a mark, etc. */ - return_NULL; - if (decoded) - return w; - } else { - /* not shared */ - wraps_key = NULL; - } - - stack_size = scheme_proper_list_length(w); - if (stack_size < 1) { - scheme_unmarshal_wrap_set(ut, wraps_key, scheme_null); - return scheme_null; - } else if (stack_size < 2) { - wc = NULL; - } else { - wc = MALLOC_WRAP_CHUNK(stack_size); - wc->type = scheme_wrap_chunk_type; - wc->len = stack_size; - } - - a = NULL; - - while (!SCHEME_NULLP(w)) { - a = SCHEME_CAR(w); - if (SCHEME_NUMBERP(a)) { - /* Re-use rename table or env rename */ - local_key = a; - a = scheme_unmarshal_wrap_get(ut, local_key, &decoded); - if (decoded && (!a || SCHEME_LISTP(a))) /* list => a whole wrap, no good as an element */ - return_NULL; - } else { - /* Not shared */ - local_key = NULL; - decoded = 0; - } - - if (decoded) { - /* done */ - } else if (SCHEME_PAIRP(a) - && SCHEME_NULLP(SCHEME_CDR(a)) - && SCHEME_NUMBERP(SCHEME_CAR(a))) { - /* Mark */ - a = unmarshal_mark(SCHEME_CAR(a), ut); - if (!a) return_NULL; - } else if (SCHEME_VECTORP(a)) { - /* A (simplified) rename table. */ - int sz = SCHEME_VEC_SIZE(a), cnt, i, any_free_id_renames = 0; - Scheme_Object *v; - - /* Make sure that it's a well-formed rename table. */ - if (sz < 2) - return_NULL; - cnt = (sz - 2) >> 1; - for (i = 0; i < cnt; i++) { - if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i + 2])) - return_NULL; - v = SCHEME_VEC_ELS(a)[i + cnt + 2]; - if (SCHEME_SYMBOLP(v)) { - /* simple target-environment symbol */ - } else if (SCHEME_PAIRP(v)) { - /* target-environment symbol paired with free-id=? rename info */ - any_free_id_renames = 1; - if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) - return_NULL; - v = SCHEME_CDR(v); - if (SCHEME_PAIRP(v)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) - return_NULL; - v = SCHEME_CDR(v); - if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v)) - return_NULL; - } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) { - if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0]) - || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1]) - || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2]) - || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[3]) - || !ok_phase(SCHEME_VEC_ELS(v)[4]) - || !ok_phase(SCHEME_VEC_ELS(v)[5]) - || !ok_phase(SCHEME_VEC_ELS(v)[6])) - return_NULL; - } else - return_NULL; - } else - return_NULL; - } - - SCHEME_VEC_ELS(a)[0] = (any_free_id_renames ? scheme_true : scheme_false); - - if (!SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) { - SCHEME_VEC_ELS(a)[1] = scheme_false; - maybe_install_rename_hash_table(a); - } - - /* It's ok: */ - scheme_unmarshal_wrap_set(ut, local_key, a); - } else if (SCHEME_PAIRP(a)) { - /* A rename table: - - ([#t] [unmarshal] #( ...) - . (( ( . ) ...) ...)) ; <- marked_names - where a is actually two values, one of: - - - - ( . ) - */ - Scheme_Object *mns; - Module_Renames *mrn; - Scheme_Object *p, *key; - int kind; - Scheme_Object *phase, *set_identity; - - if (!SCHEME_PAIRP(a)) return_NULL; - - /* Convert list to rename table: */ - - if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) { - scheme_signal_error("leftover plus-kernel"); - } - - if (!SCHEME_PAIRP(a)) return_NULL; - phase = SCHEME_CAR(a); - if (!ok_phase(phase)) return_NULL; - a = SCHEME_CDR(a); - - if (!SCHEME_PAIRP(a)) return_NULL; - if (SCHEME_TRUEP(SCHEME_CAR(a))) - kind = mzMOD_RENAME_MARKED; - else - kind = mzMOD_RENAME_NORMAL; - a = SCHEME_CDR(a); - - if (!SCHEME_PAIRP(a)) return_NULL; - set_identity = unmarshal_mark(SCHEME_CAR(a), ut); - if (!set_identity) return_NULL; - a = SCHEME_CDR(a); - - mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL); - mrn->set_identity = set_identity; - - if (!SCHEME_PAIRP(a)) return_NULL; - mns = SCHEME_CDR(a); - a = SCHEME_CAR(a); - - if (!SCHEME_VECTORP(a)) { - /* Unmarshall info: */ - Scheme_Object *ml = a, *mli, *first = scheme_null, *last = NULL, *ai; - while (SCHEME_PAIRP(ml)) { - ai = SCHEME_CAR(ml); - mli = ai; - if (!SCHEME_PAIRP(mli)) return_NULL; - - /* A module path index: */ - p = SCHEME_CAR(mli); - if (!(SCHEME_SYMBOLP(p) - || SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type))) - return_NULL; - mli = SCHEME_CDR(mli); - - if (!SCHEME_PAIRP(mli)) return_NULL; - - /* A phase/dimension index k */ - p = SCHEME_CAR(mli); - if (!ok_phase_index(p)) - return_NULL; - - p = SCHEME_CDR(mli); - if (SCHEME_PAIRP(p) && SCHEME_PAIRP(SCHEME_CAR(p))) { - /* list of marks: */ - Scheme_Object *m_first = scheme_null, *m_last = NULL, *mp, *after_marks; - - after_marks = SCHEME_CDR(p); - mli = SCHEME_CAR(p); - - while (SCHEME_PAIRP(mli)) { - p = SCHEME_CAR(mli); - p = unmarshal_mark(p, ut); - if (!p) return_NULL; - - mp = scheme_make_pair(p, scheme_null); - if (m_last) - SCHEME_CDR(m_last) = mp; - else - m_first = mp; - m_last = mp; - - mli = SCHEME_CDR(mli); - } - - /* Rebuild for unmarshaled marks: */ - ai = scheme_make_pair(SCHEME_CAR(ai), - scheme_make_pair(SCHEME_CADR(ai), - scheme_make_pair(m_first, after_marks))); - - if (!SCHEME_NULLP(mli)) return_NULL; - p = after_marks; - } - - if (ok_phase_index(p)) { - /* For a shared table: src-phase-index */ - } else { - /* For a non-shared table: (list* src-phase-index exceptions prefix), after k */ - mli = p; - if (!SCHEME_PAIRP(mli)) return_NULL; - - p = SCHEME_CAR(mli); - if (!ok_phase_index(p)) - return_NULL; - mli = SCHEME_CDR(mli); - - if (!SCHEME_PAIRP(mli)) return_NULL; - - /* A list of symbols: */ - p = SCHEME_CAR(mli); - while (SCHEME_PAIRP(p)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return_NULL; - p = SCHEME_CDR(p); - } - if (!SCHEME_NULLP(p)) return_NULL; - - /* #f or a symbol: */ - p = SCHEME_CDR(mli); - if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return_NULL; - } - - ml = SCHEME_CDR(ml); - - /* rebuild, in case we converted marks */ - p = scheme_make_pair(ai, scheme_null); - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - } - if (!SCHEME_NULLP(ml)) return_NULL; - - mrn->unmarshal_info = first; - if (SCHEME_PAIRP(first)) - mrn->needs_unmarshal = 1; - - if (!SCHEME_PAIRP(mns)) return_NULL; - a = SCHEME_CAR(mns); - mns = SCHEME_CDR(mns); - } - - if (!datum_to_module_renames(a, mrn->ht, 0, ut)) - return_NULL; - - /* Extract free-id=? renames, if any */ - if (SCHEME_PAIRP(mns) && SCHEME_VECTORP(SCHEME_CAR(mns))) { - Scheme_Hash_Table *ht; - ht = scheme_make_hash_table(SCHEME_hash_ptr); - mrn->free_id_renames = ht; - if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1, ut)) - return_NULL; - mns = SCHEME_CDR(mns); - } - - /* Extract the mark-rename table, if any: */ - if (SCHEME_PAIRP(mns)) { - Scheme_Hash_Table *ht; - Scheme_Object *ll, *kkey, *kfirst, *klast, *kp; - - ht = scheme_make_hash_table(SCHEME_hash_ptr); - for (; SCHEME_PAIRP(mns); mns = SCHEME_CDR(mns)) { - p = SCHEME_CAR(mns); - if (!SCHEME_PAIRP(p)) return_NULL; - key = SCHEME_CAR(p); - p = SCHEME_CDR(p); - if (!SCHEME_SYMBOLP(key)) return_NULL; - - ll = scheme_null; - - /* Convert marks */ - for (; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) { - a = SCHEME_CAR(p); - if (!SCHEME_PAIRP(a)) return_NULL; - kkey = SCHEME_CDR(a); - if (!SCHEME_SYMBOLP(kkey)) return_NULL; - - kfirst = scheme_null; - klast = NULL; - a = SCHEME_CAR(a); - if (SCHEME_MARKP(a)) { - kfirst = unmarshal_mark(a, ut); - } else { - Scheme_Object *bdg = NULL; - - if (SCHEME_VECTORP(a)) { - if (SCHEME_VEC_SIZE(a) != 2) return_NULL; - bdg = SCHEME_VEC_ELS(a)[1]; - if (!SCHEME_SYMBOLP(bdg)) return_NULL; - a = SCHEME_VEC_ELS(a)[0]; - } - - for (; SCHEME_PAIRP(a); a = SCHEME_CDR(a)) { - kp = CONS(unmarshal_mark(SCHEME_CAR(a), ut), scheme_null); - if (!klast) - kfirst = kp; - else - SCHEME_CDR(klast) = kp; - klast = kp; - } - if (!SCHEME_NULLP(a)) { - if (bdg && SCHEME_MARKP(a) && SCHEME_NULLP(kfirst)) - kfirst = unmarshal_mark(a, ut); - else - return_NULL; - } - - if (bdg) { - a = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(a)[0] = kfirst; - SCHEME_VEC_ELS(a)[1] = bdg; - kfirst = a; - } - } - - ll = CONS(CONS(kfirst, kkey), ll); - } - - scheme_hash_set(ht, key, ll); - - if (!SCHEME_NULLP(p)) return_NULL; - } - if (!SCHEME_NULLP(mns)) return_NULL; - - mrn->marked_names = ht; - } - - scheme_unmarshal_wrap_set(ut, local_key, (Scheme_Object *)mrn); - - scheme_seal_module_rename((Scheme_Object *)mrn, STX_SEAL_ALL); - - a = (Scheme_Object *)mrn; - } else if (SAME_OBJ(a, scheme_true) - || SCHEME_FALSEP(a)) { - /* current env rename */ - Scheme_Env *env; - - env = scheme_get_env(NULL); - scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); - a = scheme_get_module_rename_from_set(env->rename_set, - (SCHEME_FALSEP(a) - ? scheme_make_integer(1) - : scheme_make_integer(0)), - 1); - } else if (SCHEME_SYMBOLP(a)) { - /* mark barrier */ - } else if (SCHEME_BOXP(a)) { - if (SCHEME_PAIRP(SCHEME_BOX_VAL(a))) { - /* prune context */ - a = make_prune_context(SCHEME_BOX_VAL(a)); - } else { - /* must be a phase shift */ - Scheme_Object *vec; - vec = SCHEME_BOX_VAL(a); - if (!SCHEME_VECTORP(vec)) return_NULL; - if (SCHEME_VEC_SIZE(vec) != 4) return_NULL; - } - } else { - return_NULL; - } - - if (wc) - wc->a[--stack_size] = a; - - w = SCHEME_CDR(w); - } - - if (wc) - a = (Scheme_Object *)wc; - a = CONS(a, scheme_null); - - scheme_unmarshal_wrap_set(ut, wraps_key, a); - - return a; -} - -/*========================================================================*/ -/* datum->syntax */ -/*========================================================================*/ - - -#ifdef DO_STACK_CHECK -static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Stx *stx_src, - Scheme_Stx *stx_wraps, - Scheme_Hash_Table *ht); - -Scheme_Object *cert_marks_to_certs(Scheme_Object *cert_marks, - Scheme_Unmarshal_Tables *ut, - Scheme_Stx *stx_wraps, int *bad) -{ - /* Need to convert a list of marks to certs */ - Scheme_Cert *certs = NULL; - Scheme_Object *a, *b, *insp, *orig = cert_marks; - - if (SCHEME_NUMBERP(cert_marks)) { - /* Re-use rename table or env rename */ - int decoded; - a = scheme_unmarshal_wrap_get(ut, cert_marks, &decoded); - if (decoded && !a) - return_NULL; - if (decoded) - return a; - cert_marks = a; - } - - if (ut) - insp = scheme_get_cport_inspector(ut->rp); - else - insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); - - while (SCHEME_PAIRP(cert_marks)) { - a = SCHEME_CAR(cert_marks); - if (!SCHEME_NUMBERP(a)) { - *bad = 1; - return_NULL; - } - a = unmarshal_mark(a, ut); - if (!a) { *bad = 1; return_NULL; } - - cert_marks = SCHEME_CDR(cert_marks); - if (!SCHEME_PAIRP(cert_marks)) { - *bad = 1; - return_NULL; - } - b = SCHEME_CAR(cert_marks); - if (!SCHEME_SYMBOLP(b) - && !SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) { - *bad = 1; - return_NULL; - } - - if (!cert_in_chain(a, NULL, certs)) - certs = cons_cert(a, b, insp, NULL, certs); - - cert_marks = SCHEME_CDR(cert_marks); - } - if (!SCHEME_NULLP(cert_marks)) { - *bad = 1; - return_NULL; - } - - if (SCHEME_NUMBERP(orig)) { - scheme_unmarshal_wrap_set(ut, orig, (Scheme_Object *)certs); - } - - return (Scheme_Object *)certs; -} - -static Scheme_Object *datum_to_syntax_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Stx *stx_src = (Scheme_Stx *)p->ku.k.p2; - Scheme_Stx *stx_wraps = (Scheme_Stx *)p->ku.k.p3; - Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p4; - Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p5; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - p->ku.k.p5 = NULL; - - return datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht); -} -#endif - -static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Stx *stx_src, - Scheme_Stx *stx_wraps, /* or rename table, or boxed precomputed wrap */ - Scheme_Hash_Table *ht) -{ - Scheme_Object *result, *wraps, *cert_marks = NULL, *hashed; - int do_not_unpack_wraps = 0; - - if (SCHEME_STXP(o)) - return o; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)o; - p->ku.k.p2 = (void *)stx_src; - p->ku.k.p3 = (void *)stx_wraps; - p->ku.k.p4 = (void *)ht; - p->ku.k.p5 = (void *)ut; - return scheme_handle_stack_overflow(datum_to_syntax_k); - } - } -#endif - - SCHEME_USE_FUEL(1); - - if (ht) { - if (HAS_CHAPERONE_SUBSTX(o)) { - if (scheme_hash_get(ht, o)) { - /* Graphs disallowed */ - return_NULL; - } - - scheme_hash_set(ht, o, scheme_true); - hashed = o; - } else - hashed = NULL; - } else - hashed = NULL; - - if (ut && !SCHEME_BOXP(stx_wraps)) { - if (SCHEME_VECTORP(o)) { - /* This one has certs */ - if (SCHEME_VEC_SIZE(o) == 2) { - cert_marks = SCHEME_VEC_ELS(o)[1]; - o = SCHEME_VEC_ELS(o)[0]; - } else - return_NULL; - } - if (!SCHEME_PAIRP(o)) - return_NULL; - wraps = SCHEME_CDR(o); - o = SCHEME_CAR(o); - } else if (SCHEME_BOXP(stx_wraps)) { - /* Shared wraps, to be used directly everywhere: */ - wraps = SCHEME_BOX_VAL(stx_wraps); - do_not_unpack_wraps = 1; - } else - wraps = NULL; - - if (SCHEME_PAIRP(o)) { - Scheme_Object *first = NULL, *last = NULL, *p; - - /* Check whether it's all conses with - syntax inside */ - p = o; - while (SCHEME_PAIRP(p)) { - if (!SCHEME_STXP(SCHEME_CAR(p))) - break; - p = SCHEME_CDR(p); - } - if (SCHEME_NULLP(p) || SCHEME_STXP(p)) { - result = o; - } else { - int cnt = -1; - Scheme_Stx *sub_stx_wraps = stx_wraps; - - if (wraps && !SCHEME_BOXP(stx_wraps) && SAME_OBJ(SCHEME_CAR(o), scheme_true)) { - /* Resolve wraps now, and then share it with - all nested objects (as indicated by a box - for stx_wraps). */ - wraps = datum_to_wraps(wraps, ut); - do_not_unpack_wraps = 1; - sub_stx_wraps = (Scheme_Stx *)scheme_box(wraps); - o = SCHEME_CDR(o); - } else if (wraps && !SCHEME_BOXP(stx_wraps) && SCHEME_INTP(SCHEME_CAR(o))) { - /* First element is the number of items - before a non-null terminal: */ - cnt = SCHEME_INT_VAL(SCHEME_CAR(o)); - o = SCHEME_CDR(o); - } - - /* Build up a new list while converting elems */ - while (SCHEME_PAIRP(o) && cnt) { - Scheme_Object *a; - - if (ht && last) { - if (scheme_hash_get(ht, o)) { - /* cdr is shared. Stop here and let someone else complain. */ - break; - } - } - - a = datum_to_syntax_inner(SCHEME_CAR(o), ut, stx_src, sub_stx_wraps, ht); - if (!a) return_NULL; - - p = scheme_make_pair(a, scheme_null); - - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - o = SCHEME_CDR(o); - - --cnt; - } - if (!SCHEME_NULLP(o)) { - o = datum_to_syntax_inner(o, ut, stx_src, sub_stx_wraps, ht); - if (!o) return_NULL; - SCHEME_CDR(last) = o; - } - - result = first; - } - } else if (SCHEME_CHAPERONE_BOXP(o)) { - if (SCHEME_NP_CHAPERONEP(o)) - o = scheme_unbox(o); - else - o = SCHEME_PTR_VAL(o); - - o = datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht); - if (!o) return_NULL; - result = scheme_box(o); - SCHEME_SET_BOX_IMMUTABLE(result); - } else if (SCHEME_CHAPERONE_VECTORP(o)) { - int size, i; - Scheme_Object *a, *oo; - - oo = o; - if (SCHEME_NP_CHAPERONEP(o)) - o = SCHEME_CHAPERONE_VAL(o); - size = SCHEME_VEC_SIZE(o); - - result = scheme_make_vector(size, NULL); - - for (i = 0; i < size; i++) { - if (SAME_OBJ(o, oo)) - a = SCHEME_VEC_ELS(o)[i]; - else - a = scheme_chaperone_vector_ref(oo, i); - a = datum_to_syntax_inner(a, ut, stx_src, stx_wraps, ht); - if (!a) return_NULL; - SCHEME_VEC_ELS(result)[i] = a; - } - - SCHEME_SET_VECTOR_IMMUTABLE(result); - } else if (SCHEME_CHAPERONE_HASHTRP(o)) { - Scheme_Hash_Tree *ht1, *ht2; - Scheme_Object *key, *val; - int i; - - if (SCHEME_NP_CHAPERONEP(o)) - ht1 = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(o); - else - ht1 = (Scheme_Hash_Tree *)o; - - ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht1) & 0x3); - - i = scheme_hash_tree_next(ht1, -1); - while (i != -1) { - scheme_hash_tree_index(ht1, i, &key, &val); - if (!SAME_OBJ((Scheme_Object *)ht1, o)) - val = scheme_chaperone_hash_traversal_get(o, key); - val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht); - if (!val) return NULL; - ht2 = scheme_hash_tree_set(ht2, key, val); - i = scheme_hash_tree_next(ht1, i); - } - - result = (Scheme_Object *)ht2; - } else if (prefab_p(o) || (SCHEME_CHAPERONEP(o) && prefab_p(SCHEME_CHAPERONE_VAL(o)))) { - Scheme_Structure *s; - Scheme_Object *a; - int size, i; - - s = (Scheme_Structure *)scheme_clone_prefab_struct_instance((Scheme_Structure *)o); - size = s->stype->num_slots; - - for (i = 0; i < size; i++) { - a = datum_to_syntax_inner(s->slots[i], ut, stx_src, stx_wraps, ht); - if (!a) return NULL; - s->slots[i] = a; - } - - result = (Scheme_Object *)s; - } else { - result = o; - } - - if (SCHEME_FALSEP((Scheme_Object *)stx_src)) - result = scheme_make_stx(result, empty_srcloc, NULL); - else - result = scheme_make_stx(result, stx_src->srcloc, NULL); - - if (wraps) { - if (!do_not_unpack_wraps) { - wraps = datum_to_wraps(wraps, ut); - if (!wraps) - return_NULL; - } - ((Scheme_Stx *)result)->wraps = wraps; - } else if (SCHEME_FALSEP((Scheme_Object *)stx_wraps)) { - /* wraps already nulled */ - } else { - /* Note: no propagation will be needed for SUBSTX */ - ((Scheme_Stx *)result)->wraps = stx_wraps->wraps; - } - - if (cert_marks) { - /* Need to convert a list of marks to certs */ - Scheme_Object *certs; - int bad = 0; - - if (SCHEME_PAIRP(cert_marks) - && (SCHEME_PAIRP(SCHEME_CAR(cert_marks)) - || SCHEME_NULLP(SCHEME_CAR(cert_marks)) - || SCHEME_FALSEP(SCHEME_CAR(cert_marks)))) { - /* Have both active and inactive certs */ - Scheme_Object *icerts; - if (SCHEME_FALSEP(SCHEME_CAR(cert_marks))) - cert_marks = SCHEME_CDR(cert_marks); - certs = cert_marks_to_certs(SCHEME_CAR(cert_marks), ut, stx_wraps, &bad); - icerts = cert_marks_to_certs(SCHEME_CDR(cert_marks), ut, stx_wraps, &bad); - certs = scheme_make_raw_pair(certs, icerts); - } else { - /* Just active certs */ - certs = cert_marks_to_certs(cert_marks, ut, stx_wraps, &bad); - } - if (bad) - return_NULL; - ((Scheme_Stx *)result)->certs = certs; - } - - if (hashed) { - scheme_hash_set(ht, hashed, NULL); - } - - return result; -} - -static Scheme_Object *general_datum_to_syntax(Scheme_Object *o, - Scheme_Unmarshal_Tables *ut, - Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int can_graph, int copy_props) - /* If stx_wraps is a hash table, then `o' includes marks and certs. - If copy_props > 0, properties are copied from src. - If copy_props != 1 or 0, then certs are copied from src, too. */ -{ - Scheme_Hash_Table *ht; - Scheme_Object *v, *code = NULL; - - if (!SCHEME_FALSEP(stx_src) && !SCHEME_STXP(stx_src)) - return o; - - if (SCHEME_STXP(o)) - return o; - - if (can_graph && HAS_CHAPERONE_SUBSTX(o)) - ht = scheme_make_hash_table(SCHEME_hash_ptr); - else - ht = NULL; - - if (ut) { - /* If o is just a number, look it up in the table. */ - if (SCHEME_INTP(o)) { - int decoded; - v = scheme_unmarshal_wrap_get(ut, o, &decoded); - if (!decoded) { - code = o; - o = v; - } else - return v; - } - } - - v = datum_to_syntax_inner(o, - ut, - (Scheme_Stx *)stx_src, - (Scheme_Stx *)stx_wraps, - ht); - - if (!v) { - if (ut) - return_NULL; /* happens with bad wraps from a bad .zo */ - /* otherwise, only happens with cycles: */ - scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "datum->syntax: cannot create syntax from cyclic datum: %V", - o); - return NULL; - } - - if (code) { - scheme_unmarshal_wrap_set(ut, code, v); - } - - if (copy_props > 0) - ((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props; - - if (copy_props && (copy_props != 1)) { - if (ACTIVE_CERTS(((Scheme_Stx *)stx_src))) - v = add_certs(v, ACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 1); - if (INACTIVE_CERTS((Scheme_Stx *)stx_src)) { - v = lift_inactive_certs(v, 0); - v = add_certs(v, INACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 0); - } - } - - return v; -} - -Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, - Scheme_Object *stx_src, - Scheme_Object *stx_wraps, - int can_graph, int copy_props) -{ - return general_datum_to_syntax(o, NULL, stx_src, stx_wraps, can_graph, copy_props); -} - -Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, - struct Scheme_Unmarshal_Tables *ut, - int can_graph) -{ - return general_datum_to_syntax(o, ut, scheme_false, scheme_false, can_graph, 0); -} - -/*========================================================================*/ -/* simplify */ -/*========================================================================*/ - -#ifdef DO_STACK_CHECK -static void simplify_syntax_inner(Scheme_Object *o, - Scheme_Hash_Table *rns, - Scheme_Hash_Table *marks); - -static Scheme_Object *simplify_syntax_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; - Scheme_Hash_Table *rns = (Scheme_Hash_Table *)p->ku.k.p2; - Scheme_Hash_Table *marks = (Scheme_Hash_Table *)p->ku.k.p3; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - - simplify_syntax_inner(o, rns, marks); - - return NULL; -} -#endif - -static void simplify_syntax_inner(Scheme_Object *o, - Scheme_Hash_Table *rns, - Scheme_Hash_Table *marks) -{ - Scheme_Stx *stx = (Scheme_Stx *)o; - Scheme_Object *v; - -#ifdef DO_STACK_CHECK - { -# include "mzstkchk.h" - { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = (void *)o; - p->ku.k.p2 = (void *)rns; - p->ku.k.p3 = (void *)marks; - scheme_handle_stack_overflow(simplify_syntax_k); - return; - } - } -#endif - SCHEME_USE_FUEL(1); - - /* Propagate wraps: */ - scheme_stx_content((Scheme_Object *)stx); - - if (rns) { - v = wraps_to_datum(stx->val, stx->wraps, NULL, rns, 1); - stx->wraps = v; - } - - if (stx->certs && !marks) - marks = scheme_make_hash_table(SCHEME_hash_ptr); - - v = stx->val; - - if (SCHEME_PAIRP(v)) { - while (SCHEME_PAIRP(v)) { - simplify_syntax_inner(SCHEME_CAR(v), rns, marks); - v = SCHEME_CDR(v); - } - if (!SCHEME_NULLP(v)) { - simplify_syntax_inner(v, rns, marks); - } - } else if (SCHEME_BOXP(v)) { - simplify_syntax_inner(SCHEME_BOX_VAL(v), rns, marks); - } else if (SCHEME_VECTORP(v)) { - int size = SCHEME_VEC_SIZE(v), i; - - for (i = 0; i < size; i++) { - simplify_syntax_inner(SCHEME_VEC_ELS(v)[i], rns, marks); - } - } else if (SCHEME_HASHTRP(v)) { - Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v; - Scheme_Object *key, *val; - int i; - - i = scheme_hash_tree_next(ht, -1); - while (i != -1) { - scheme_hash_tree_index(ht, i, &key, &val); - simplify_syntax_inner(val, rns, marks); - i = scheme_hash_tree_next(ht, i); - } - } else if (prefab_p(v)) { - Scheme_Structure *s = (Scheme_Structure *)v; - int size = s->stype->num_slots, i; - - for (i = 0; i < size; i++) { - simplify_syntax_inner(s->slots[i], rns, marks); - } - } - - if (marks) - add_all_marks(stx->wraps, marks); - - /* Pare certs based on marks that are actually used, - and eliminate redundant certs. */ - if (stx->certs) { - Scheme_Cert *orig_certs, *certs, *cl, *all_used_after, *result; - int i; - for (i = 0; i < 2; i++) { - if (!i) - certs = ACTIVE_CERTS(stx); - else - certs = INACTIVE_CERTS(stx); - orig_certs = certs; - /* Is there a tail where all certs are used? */ - all_used_after = certs; - for (cl = certs; cl; cl = cl->next) { - if (!scheme_hash_get(marks, cl->mark)) - all_used_after = cl->next; - } - /* In the all-used tail, are any redundant? */ - for (cl = all_used_after; cl; cl = cl->next) { - v = scheme_hash_get(marks, cl->mark); - if (SCHEME_VOIDP(v)) { - /* Reset marks, because we're giving up on all_used_after */ - result = cl; - for (cl = all_used_after; cl != result; cl = cl->next) { - scheme_hash_set(marks, cl->mark, scheme_true); - } - all_used_after = NULL; - break; - } - scheme_hash_set(marks, cl->mark, scheme_void); - } - /* If any marks are unused or redundant, then all_used_after will - have been changed. Also, every mark in all_used_after is mapped - to void instead of true in the marks hash table. */ - if (all_used_after != certs) { - /* We can simplify... */ - result = all_used_after; - for (cl = orig_certs; cl; cl = cl->next) { - if (SAME_OBJ(cl, all_used_after)) - break; - if (scheme_hash_get(marks, cl->mark)) { - v = scheme_hash_get(marks, cl->mark); - if (!SCHEME_VOIDP(v)) - result = cons_cert(cl->mark, cl->modidx, cl->insp, cl->key, result); - } - } - if (!i) { - if (SCHEME_RPAIRP(stx->certs)) { - Scheme_Object *pr; - pr = scheme_make_raw_pair((Scheme_Object *)result, SCHEME_CDR(stx->certs)); - stx->certs = pr; - } else - stx->certs = (Scheme_Object *)result; - } else { - if (!result) - stx->certs = SCHEME_CAR(stx->certs); - else { - Scheme_Object *pr; - pr = scheme_make_raw_pair(SCHEME_CAR(stx->certs), (Scheme_Object *)result); - stx->certs = pr; - } - } - } - /* Reset mark map from void to true: */ - for (cl = all_used_after; cl; cl = cl->next) { - scheme_hash_set(marks, cl->mark, scheme_true); - } - } - } -} - -Scheme_Object *scheme_new_stx_simplify_cache() -{ - return (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); -} - -void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) -{ -#if 0 - if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { - fprintf(stderr, - "simplifying... %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), - NULL)); - explain_simp = 1; - } -#endif - - if (cache) { - Scheme_Hash_Table *rns; - - rns = (Scheme_Hash_Table *)cache; - - simplify_syntax_inner(stx, rns, NULL); - } - -#if 0 - if (explain_simp) { - explain_simp = 0; - fprintf(stderr, "simplified: %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), - NULL)); - } -#endif -} - -/*========================================================================*/ -/* Scheme functions and helpers */ -/*========================================================================*/ - -static Scheme_Object *syntax_p(int argc, Scheme_Object **argv) -{ - return SCHEME_STXP(argv[0]) ? scheme_true : scheme_false; -} - -static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax->datum", "syntax", 0, argc, argv); - - return scheme_syntax_to_datum(argv[0], 0, NULL); -} - -static int nonneg_exact_or_false_p(Scheme_Object *o) -{ - return SCHEME_FALSEP(o) || scheme_nonneg_exact_p(o); -} - -static int pos_exact_or_false_p(Scheme_Object *o) -{ - return (SCHEME_FALSEP(o) - || (SCHEME_INTP(o) && (SCHEME_INT_VAL(o) > 0)) - || (SCHEME_BIGNUMP(o) && SCHEME_BIGPOS(o))); -} - -static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv) -{ - Scheme_Object *src = scheme_false, *properties = NULL, *certs = NULL; - - if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0])) - scheme_wrong_type("datum->syntax", "syntax or #f", 0, argc, argv); - if (argc > 2) { - int ll; - - src = argv[2]; - - ll = scheme_proper_list_length(src); - - if (SCHEME_CHAPERONEP(src)) { - src = SCHEME_CHAPERONE_VAL(src); - if (SCHEME_VECTORP(src) && (SCHEME_VEC_SIZE(src) == 5)) { - Scheme_Object *a; - int i; - src = scheme_make_vector(5, NULL); - for (i = 0; i < 5; i++) { - a = scheme_chaperone_vector_ref(argv[2], i); - SCHEME_VEC_ELS(src)[i] = a; - } - } - } - - if (!SCHEME_FALSEP(src) - && !SCHEME_STXP(src) - && !(SCHEME_VECTORP(src) - && (SCHEME_VEC_SIZE(src) == 5) - && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[1]) - && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[2]) - && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[3]) - && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[4])) - && !((ll == 5) - && pos_exact_or_false_p(SCHEME_CADR(src)) - && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(src))) - && pos_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src)))) - && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src))))))) - scheme_wrong_type("datum->syntax", "syntax, source location vector or list, or #f", 2, argc, argv); - - if (SCHEME_VECTORP(src)) - ll = 5; - - if (argc > 3) { - if (!SCHEME_FALSEP(argv[3])) { - if (!SCHEME_STXP(argv[3])) - scheme_wrong_type("datum->syntax", "syntax or #f", 3, argc, argv); - properties = ((Scheme_Stx *)argv[3])->props; - } - - if (argc > 4) { - if (!SCHEME_FALSEP(argv[4])) { - if (!SCHEME_STXP(argv[4])) - scheme_wrong_type("datum->syntax", "syntax or #f", 4, argc, argv); - certs = (Scheme_Object *)INACTIVE_CERTS((Scheme_Stx *)argv[4]); - } - } - } - - if (ll == 5) { - /* line--column--pos--span format */ - Scheme_Object *line, *col, *pos, *span; - if (SCHEME_VECTORP(src)) { - line = SCHEME_VEC_ELS(src)[1]; - col = SCHEME_VEC_ELS(src)[2]; - pos = SCHEME_VEC_ELS(src)[3]; - span = SCHEME_VEC_ELS(src)[4]; - src = SCHEME_VEC_ELS(src)[0]; - } else { - line = SCHEME_CADR(src); - col = SCHEME_CADR(SCHEME_CDR(src)); - pos = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src))); - span = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src)))); - src = SCHEME_CAR(src); - } - - if (SCHEME_FALSEP(line) != SCHEME_FALSEP(col)) - scheme_arg_mismatch("datum->syntax", - "line and column positions must both be numbers or #f in: ", - argv[2]); - - /* Too-large positions go to unknown */ - if (SCHEME_BIGNUMP(line) || SCHEME_BIGNUMP(col)) { - line = scheme_make_integer(-1); - col = scheme_make_integer(-1); - } - if (SCHEME_BIGNUMP(pos)) - pos = scheme_make_integer(-1); - if (span && SCHEME_BIGNUMP(span)) - span = scheme_make_integer(-1); - - src = scheme_make_stx_w_offset(scheme_false, - SCHEME_FALSEP(line) ? -1 : SCHEME_INT_VAL(line), - SCHEME_FALSEP(col) ? -1 : (SCHEME_INT_VAL(col)+1), - SCHEME_FALSEP(pos) ? -1 : SCHEME_INT_VAL(pos), - SCHEME_FALSEP(span) ? -1 : SCHEME_INT_VAL(span), - src, - NULL); - } - } - - if (SCHEME_STXP(argv[1])) - return argv[1]; - - src = scheme_datum_to_syntax(argv[1], src, argv[0], 1, 0); - - if (properties) { - ((Scheme_Stx *)src)->props = properties; - } - - if (certs) - src = add_certs(src, (Scheme_Cert *)certs, NULL, 0); - - return src; -} - - -Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-e", "syntax", 0, argc, argv); - - return scheme_stx_content(argv[0]); -} - -static Scheme_Object *syntax_line(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-line", "syntax", 0, argc, argv); - - if (stx->srcloc->line < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->line); -} - -static Scheme_Object *syntax_col(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-column", "syntax", 0, argc, argv); - - if (stx->srcloc->col < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->col-1); -} - -static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-position", "syntax", 0, argc, argv); - - if (stx->srcloc->pos < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->pos); -} - -static Scheme_Object *syntax_span(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-span", "syntax", 0, argc, argv); - - if (stx->srcloc->span < 0) - return scheme_false; - else - return scheme_make_integer(stx->srcloc->span); -} - -static Scheme_Object *syntax_src(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-source", "syntax", 0, argc, argv); - - return stx->srcloc->src; -} - -static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv) -{ - Scheme_Object *l; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax->list", "syntax", 0, argc, argv); - - l = scheme_stx_content(argv[0]); - if (SCHEME_NULLP(l)) - return scheme_null; - else if (SCHEME_PAIRP(l)) { - int islist; - l = scheme_flatten_syntax_list(l, &islist); - if (islist) - return l; - else - return scheme_false; - } else - return scheme_false; -} - -static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx; - WRAP_POS awl; - WRAP_POS ewl; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-original?", "syntax", 0, argc, argv); - - stx = (Scheme_Stx *)argv[0]; - - if (stx->props) { - if (SAME_OBJ(stx->props, STX_SRCTAG)) { - /* Check for marks... */ - } else { - Scheme_Object *e; - - for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { - if (SAME_OBJ(source_symbol, SCHEME_CAR(SCHEME_CAR(e)))) { - break; - } - } - - if (SCHEME_NULLP(e)) - return scheme_false; - } - } else - return scheme_false; - - WRAP_POS_INIT(awl, stx->wraps); - WRAP_POS_INIT_END(ewl); - - if (same_marks(&awl, &ewl, scheme_false)) - return scheme_true; - else - return scheme_false; -} - -Scheme_Object *scheme_stx_property(Scheme_Object *_stx, - Scheme_Object *key, - Scheme_Object *val) -{ - Scheme_Stx *stx; - Scheme_Object *l; - - stx = (Scheme_Stx *)_stx; - - if (stx->props) { - if (SAME_OBJ(stx->props, STX_SRCTAG)) { - if (val) - l = CONS(CONS(source_symbol, scheme_true), - scheme_null); - else - l = NULL; - } else { - Scheme_Object *e; - - for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { - if (SAME_OBJ(key, SCHEME_CAR(SCHEME_CAR(e)))) { - if (val) - break; - else - return SCHEME_CDR(SCHEME_CAR(e)); - } - } - - if (SCHEME_NULLP(e)) - l = stx->props; - else { - /* Remove existing binding: */ - Scheme_Object *first = scheme_null, *last = NULL, *p; - - for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { - if (SAME_OBJ(key, SCHEME_CAR(SCHEME_CAR(e)))) { - p = SCHEME_CDR(e); - e = NULL; - } else { - p = CONS(SCHEME_CAR(e), scheme_null); - } - - if (last) - SCHEME_CDR(last) = p; - else - first = p; - last = p; - - if (!e) - break; - } - - l = first; - } - } - } else - l = scheme_null; - - if (val) { - Scheme_Object *wraps, *modinfo_cache; - Scheme_Object *certs; - intptr_t lazy_prefix; - - l = CONS(CONS(key, val), l); - - wraps = stx->wraps; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - modinfo_cache = NULL; - lazy_prefix = stx->u.lazy_prefix; - } else { - modinfo_cache = stx->u.modinfo_cache; - lazy_prefix = 0; - } - certs = stx->certs; - - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, l); - - stx->wraps = wraps; - if (modinfo_cache) - stx->u.modinfo_cache = modinfo_cache; - else - stx->u.lazy_prefix = lazy_prefix; /* same as NULL modinfo if no SUBSTX */ - stx->certs = certs; - - return (Scheme_Object *)stx; - } else - return scheme_false; -} - -static Scheme_Object *syntax_property(int argc, Scheme_Object **argv) -{ - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-property", "syntax", 0, argc, argv); - - return scheme_stx_property(argv[0], - argv[1], - (argc > 2) ? argv[2] : NULL); -} - -static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) -{ - Scheme_Stx *stx; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-property-symbol-keys", "syntax", 0, argc, argv); - - stx = (Scheme_Stx *)argv[0]; - - if (stx->props) { - if (!SAME_OBJ(stx->props, STX_SRCTAG)) { - Scheme_Object *e, *k, *l = scheme_null; - - for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { - k = SCHEME_CAR(SCHEME_CAR(e)); - if (SCHEME_SYMBOLP(k) && !SCHEME_SYM_WEIRDP(k)) - l = scheme_make_pair(k, l); - } - return l; - } - } - - return scheme_null; -} - -#define SCHEME_STX_IDP(o) (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))) - -static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv) -{ - Scheme_Object *result, *observer; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-track-origin", "syntax", 0, argc, argv); - if (!SCHEME_STXP(argv[1])) - scheme_wrong_type("syntax-track-origin", "syntax", 1, argc, argv); - if (!SCHEME_STX_IDP(argv[2])) - scheme_wrong_type("syntax-track-origin", "identifier syntax", 2, argc, argv); - - result = scheme_stx_track(argv[0], argv[1], argv[2]); - observer = scheme_get_expand_observe(); - SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(observer, argv[0], result); - return result; -} - -Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from) -{ - if (!SAME_OBJ(((Scheme_Stx *)from)->srcloc, empty_srcloc)) { - Scheme_Stx *stx = (Scheme_Stx *)to; - Scheme_Object *wraps, *modinfo_cache; - Scheme_Object *certs; - intptr_t lazy_prefix; - - wraps = stx->wraps; - if (STX_KEY(stx) & STX_SUBSTX_FLAG) { - modinfo_cache = NULL; - lazy_prefix = stx->u.lazy_prefix; - } else { - modinfo_cache = stx->u.modinfo_cache; - lazy_prefix = 0; - } - certs = stx->certs; - - stx = (Scheme_Stx *)scheme_make_stx(stx->val, - ((Scheme_Stx *)from)->srcloc, - stx->props); - - stx->wraps = wraps; - if (modinfo_cache) - stx->u.modinfo_cache = modinfo_cache; - else - stx->u.lazy_prefix = lazy_prefix; /* same as NULL modinfo if no SUBSTX */ - stx->certs = certs; - - return (Scheme_Object *)stx; - } else - return to; -} - -static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p) -{ - Scheme_Object *r, *delta; - - r = argv[0]; - - if (!SCHEME_STXP(r)) - scheme_wrong_type("delta-introducer", "syntax", 0, argc, argv); - - delta = SCHEME_PRIM_CLOSURE_ELS(p)[0]; - - for(; !SCHEME_NULLP(delta); delta = SCHEME_CDR(delta)) { - r = scheme_add_remove_mark(r, SCHEME_CAR(delta)); - } - - return r; -} - -static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_Object **argv, - Scheme_Object *delta, int use_shift) -{ - Scheme_Object *phase; - - if (argc > pos) { - phase = argv[pos]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_type(who, "exact integer or #f", pos, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - intptr_t ph; - ph = (p->current_local_env - ? p->current_local_env->genv->phase - : (use_shift - ? p->current_phase_shift - : 0)); - phase = scheme_make_integer(ph); - - if (SCHEME_FALSEP(delta) || SCHEME_FALSEP(phase)) - phase = scheme_false; - else - phase = scheme_bin_plus(delta, phase); - } - - return phase; -} - -Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) -{ - Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1]; - int l1, l2; - Scheme_Object *phase; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) - scheme_wrong_type("make-syntax-delta-introducer", "syntax identifier", 0, argc, argv); - if (!SCHEME_STXP(argv[1]) && !SCHEME_FALSEP(argv[1])) - scheme_wrong_type("make-syntax-delta-introducer", "syntax or #f", 1, argc, argv); - - phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1); - - m1 = scheme_stx_extract_marks(argv[0]); - orig_m1 = m1; - l1 = scheme_list_length(m1); - delta = scheme_null; - if (SCHEME_FALSEP(argv[1])) { - m2 = scheme_false; - } else { - m2 = scheme_stx_extract_marks(argv[1]); - - l2 = scheme_list_length(m2); - - while (l1 > l2) { - delta = CONS(SCHEME_CAR(m1), delta); - m1 = SCHEME_CDR(m1); - l1--; - } - } - - if (!scheme_equal(m1, m2)) { - /* tails don't match, so keep all marks --- except - those that determine a module binding */ - int skipped = -1; - Scheme_Object *mod; - - mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, - scheme_make_hash_table(SCHEME_hash_ptr)); - - if ((skipped == -1) && SCHEME_FALSEP(mod)) { - /* For top-level bindings, need to check the current environment's table, - because the identifier might not have the top level in its renamings. */ - Scheme_Env *env; - - if (scheme_current_thread->current_local_env) - env = scheme_current_thread->current_local_env->genv; - else - env = NULL; - if (!env) env = scheme_get_env(NULL); - if (env) { - scheme_tl_id_sym(env, argv[0], NULL, 0, NULL, &skipped); - } - } - - if (skipped > -1) { - /* Just keep the first `skipped' marks. */ - delta = scheme_null; - m1 = orig_m1; - while (skipped) { - delta = CONS(SCHEME_CAR(m1), delta); - m1 = SCHEME_CDR(m1); - skipped--; - } - } else { - /* Keep them all */ - while (l1) { - delta = CONS(SCHEME_CAR(m1), delta); - m1 = SCHEME_CDR(m1); - l1--; - } - } - } - - a[0] = delta; - - return scheme_make_prim_closure_w_arity(delta_introducer, 1, a, "delta-introducer", 1, 1); -} - -static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) -{ - Scheme_Object *phase; - - if (!SCHEME_STX_IDP(argv[0])) - scheme_wrong_type("bound-identifier=?", "identifier syntax", 0, argc, argv); - if (!SCHEME_STX_IDP(argv[1])) - scheme_wrong_type("bound-identifier=?", "identifier syntax", 1, argc, argv); - - phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0); - - return (scheme_stx_bound_eq(argv[0], argv[1], phase) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_Object **argv) -{ - Scheme_Object *phase; - - if (!SCHEME_STX_IDP(argv[0])) - scheme_wrong_type(who, "identifier syntax", 0, argc, argv); - if (!SCHEME_STX_IDP(argv[1])) - scheme_wrong_type(who, "identifier syntax", 1, argc, argv); - - phase = extract_phase(who, 2, argc, argv, - ((delta == MZ_LABEL_PHASE) - ? scheme_false - : scheme_make_integer(delta)), - 0); - - return (scheme_stx_module_eq2(argv[0], argv[1], phase, NULL) - ? scheme_true - : scheme_false); -} - -static Scheme_Object *module_eq(int argc, Scheme_Object **argv) -{ - return do_module_eq("free-identifier=?", 0, argc, argv); -} - -static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv) -{ - return do_module_eq("free-transformer-identifier=?", 1, argc, argv); -} - -static Scheme_Object *module_templ_eq(int argc, Scheme_Object **argv) -{ - return do_module_eq("free-template-identifier=?", -1, argc, argv); -} - -static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv) -{ - return do_module_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv); -} - -static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv, Scheme_Object *dphase) -{ - Scheme_Object *a, *m, *nom_mod, *nom_a, *phase; - Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase; - - a = argv[0]; - - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_type(name, "identifier syntax", 0, argc, argv); - - phase = extract_phase(name, 1, argc, argv, dphase, 1); - - if (argc > 1) { - phase = argv[1]; - if (!SCHEME_FALSEP(phase) - && !SCHEME_INTP(phase) - && !SCHEME_BIGNUMP(phase)) - scheme_wrong_type(name, "exact integer or #f", 1, argc, argv); - } else { - Scheme_Thread *p = scheme_current_thread; - phase = scheme_make_integer(p->current_local_env - ? p->current_local_env->genv->phase - : p->current_phase_shift); - if (SCHEME_FALSEP(dphase) || SCHEME_FALSEP(phase)) - phase = scheme_false; - else - phase = scheme_bin_plus(dphase, phase); - } - - m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr), - &a, - phase, - &nom_mod, &nom_a, - &mod_phase, - &src_phase_index, - &nominal_src_phase, - NULL, - NULL, - NULL); - - if (!m) - return scheme_false; - else if (SAME_OBJ(m, scheme_undefined)) { - return lexical_symbol; - } else - return CONS(m, CONS(a, CONS(nom_mod, - CONS(nom_a, - CONS(mod_phase, - CONS(src_phase_index, - CONS(nominal_src_phase, - scheme_null))))))); -} - -static Scheme_Object *module_binding(int argc, Scheme_Object **argv) -{ - return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0)); -} - -static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv) -{ - return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1)); -} - -static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv) -{ - return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1)); -} - -static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv) -{ - return do_module_binding("identifier-label-binding", argc, argv, scheme_false); -} - -static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv) -{ - Scheme_Object *a = argv[0], *p, *l; - - if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) - scheme_wrong_type("identifier-prune-lexical-context", "identifier syntax", 0, argc, argv); - - if (argc > 1) { - l = argv[1]; - while (SCHEME_PAIRP(l)) { - if (!SCHEME_SYMBOLP(SCHEME_CAR(l))) - break; - l = SCHEME_CDR(l); - } - if (!SCHEME_NULLP(l)) - scheme_wrong_type("identifier-prune-lexical-context", "list of symbols", 1, argc, argv); - l = argv[1]; - } else { - l = scheme_make_pair(SCHEME_STX_VAL(a), scheme_null); - } - - p = make_prune_context(l); - - return scheme_add_rename(a, p); -} - -static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv) -{ - WRAP_POS w; - Scheme_Stx *stx = (Scheme_Stx *)argv[0]; - Scheme_Object *l = scheme_null; - - if (!SCHEME_STXP(argv[0]) || !SCHEME_STX_SYMBOLP(argv[0])) - scheme_wrong_type("identifier-prune-to-source-module", "identifier syntax", 0, argc, argv); - - /* Keep only redirecting phase shifts */ - - WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); - while (!WRAP_POS_END_P(w)) { - if (SCHEME_BOXP(WRAP_POS_FIRST(w))) { - /* Phase shift: */ - Scheme_Object *vec, *dest, *src; - - vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(w)); - - src = SCHEME_VEC_ELS(vec)[1]; - dest = SCHEME_VEC_ELS(vec)[2]; - - /* If src is #f, shift is just for phase; no redirection */ - if (!SCHEME_FALSEP(src)) { - l = scheme_make_pair(WRAP_POS_FIRST(w), l); - } - } - - WRAP_POS_INC(w); - } - - l = scheme_reverse(l); - - stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); - stx->wraps = l; - - return (Scheme_Object *)stx; -} - -static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv) -{ - int source = 0; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-source-module", "syntax", 0, argc, argv); - - if ((argc > 1) && SCHEME_TRUEP(argv[1])) - source = 1; - - return scheme_stx_source_module(argv[0], source, source); -} - -/**********************************************************************/ - -static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv) -{ - Scheme_Object *insp, *key; - - if (!SCHEME_STXP(argv[0])) - scheme_wrong_type("syntax-recertify", "syntax", 0, argc, argv); - if (!SCHEME_STXP(argv[1])) - scheme_wrong_type("syntax-recertify", "syntax", 1, argc, argv); - if (SCHEME_TRUEP(argv[2]) && !SAME_TYPE(SCHEME_TYPE(argv[2]), scheme_inspector_type)) - scheme_wrong_type("syntax-recertify", "inspector or #f", 2, argc, argv); - - if (SAME_OBJ(argv[0], argv[1])) - return argv[0]; - - insp = argv[2]; - if (SCHEME_FALSEP(insp)) - insp = NULL; - key = argv[3]; - - if (((Scheme_Stx *)argv[1])->certs) { - Scheme_Stx *stx, *res; - Scheme_Cert *certs, *new_certs, *orig_certs; - int i; - - stx = (Scheme_Stx *)argv[0]; - - for (i = 0; i < 2; i++) { - if (!i) { - certs = ACTIVE_CERTS((Scheme_Stx *)argv[1]); - new_certs = ACTIVE_CERTS(stx); - } else { - certs = INACTIVE_CERTS((Scheme_Stx *)argv[1]); - new_certs = INACTIVE_CERTS(stx); - } - - orig_certs = new_certs; - - while (certs) { - if (!SAME_OBJ(certs->key, key) - && !SAME_OBJ(certs->insp, insp) - && (!insp || !scheme_is_subinspector(certs->insp, insp))) { - /* Drop opaque certification. */ - } else { - if (!cert_in_chain(certs->mark, certs->key, new_certs)) - new_certs = cons_cert(certs->mark, certs->modidx, certs->insp, certs->key, new_certs); - } - certs = certs->next; - } - - if (!SAME_OBJ(orig_certs, new_certs)) { - if (i && !orig_certs) - stx = (Scheme_Stx *)lift_inactive_certs((Scheme_Object *)stx, 0); - - res = (Scheme_Stx *)scheme_make_stx(stx->val, - stx->srcloc, - stx->props); - res->wraps = stx->wraps; - res->u.lazy_prefix = stx->u.lazy_prefix; - - if (!i && (!stx->certs || !SCHEME_RPAIRP(stx->certs) || !SCHEME_CDR(stx->certs))) - res->certs = (Scheme_Object *)new_certs; - else { - Scheme_Object *pr; - if (!i) - pr = scheme_make_raw_pair((Scheme_Object *)new_certs, SCHEME_CDR(stx->certs)); - else - pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)new_certs); - res->certs = pr; - } - - stx = res; - } - } - - return (Scheme_Object *)stx; - } else - return argv[0]; -} - -/**********************************************************************/ -/* Debugging */ -/**********************************************************************/ - -static Scheme_Object *explode_cert_chain(Scheme_Cert *c, Scheme_Hash_Table *ht) -{ - Scheme_Object *first = scheme_null, *last = NULL, *pr, *vec; - Scheme_Cert *next; - int depth = c ? c->depth : 0; - - while (c) { - next = c->next; - pr = scheme_hash_get(ht, (Scheme_Object *)c); - if (!pr) { - vec = scheme_make_vector(3, NULL); - SCHEME_VEC_ELS(vec)[0] = c->mark; - SCHEME_VEC_ELS(vec)[1] = (c->modidx ? c->modidx : scheme_false); - SCHEME_VEC_ELS(vec)[2] = (c->key ? c->key : scheme_false); - pr = scheme_make_pair(vec, scheme_null); - scheme_hash_set(ht, (Scheme_Object *)c, pr); - } else - next = NULL; - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - c = next; - } - - if (!SCHEME_NULLP(first)) { - first = scheme_make_pair(scheme_make_integer(depth), first); - } - - return first; -} - -static Scheme_Object *explode_certs(Scheme_Stx *stx, Scheme_Hash_Table *ht) -{ - Scheme_Cert *a, *i; - - a = ACTIVE_CERTS(stx); - i = INACTIVE_CERTS(stx); - - return scheme_make_pair(explode_cert_chain(a, ht), - explode_cert_chain(i, ht)); -} - -static Scheme_Object *explode_wraps(Scheme_Object *wraps, Scheme_Hash_Table *ht) -{ - Scheme_Object *key, *prev_key = NULL, *pr, *first = scheme_null, *last = NULL, *v; - WRAP_POS awl; - - WRAP_POS_INIT(awl, wraps); - - while (!WRAP_POS_END_P(awl)) { - key = WRAP_POS_KEY(awl); - if (key != prev_key) { - pr = scheme_hash_get(ht, key); - if (pr) { - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - break; - } else { - pr = scheme_make_pair(scheme_void, scheme_null); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - pr = scheme_make_pair(scheme_false, scheme_null); - scheme_hash_set(ht, key, pr); - } - prev_key = key; - } else { - pr = scheme_make_pair(scheme_false, scheme_null); - } - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - - v = WRAP_POS_FIRST(awl); - - if (SCHEME_RENAMESP(v)) { - Module_Renames *mrn = (Module_Renames *)v; - Scheme_Object *o; - - v = scheme_hash_get(ht, (Scheme_Object *)mrn); - if (!v) { - v = scheme_make_vector(7, NULL); - o = scheme_intern_symbol("rename:"); - SCHEME_VEC_ELS(v)[0] = o; - SCHEME_VEC_ELS(v)[1] = mrn->phase; - SCHEME_VEC_ELS(v)[2] = (Scheme_Object *)mrn->ht; - SCHEME_VEC_ELS(v)[3] = (mrn->nomarshal_ht ? (Scheme_Object *)mrn->nomarshal_ht : scheme_false); - SCHEME_VEC_ELS(v)[4] = scheme_true; /* mrn->shared_pes; */ - SCHEME_VEC_ELS(v)[5] = (mrn->marked_names ? (Scheme_Object *)mrn->marked_names : scheme_false); - SCHEME_VEC_ELS(v)[6] = (Scheme_Object *)mrn->unmarshal_info; - scheme_hash_set(ht, (Scheme_Object *)mrn, v); - } - } - - SCHEME_CAR(pr) = v; - - WRAP_POS_INC(awl); - } - - return first; -} - -Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) -{ - Scheme_Object *vec, *v; - - if (SCHEME_PAIRP(stx)) { - return scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(stx), ht), - scheme_explode_syntax(SCHEME_CDR(stx), ht)); - } - if (SCHEME_NULLP(stx)) - return scheme_null; - - vec = scheme_hash_get(ht, stx); - if (vec) - return vec; - - vec = scheme_make_vector(3, NULL); - scheme_hash_set(ht, stx, vec); - - v = ((Scheme_Stx *)stx)->val; - if (SCHEME_PAIRP(v)) { - v = scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(v), ht), - scheme_explode_syntax(SCHEME_CDR(v), ht)); - } - SCHEME_VEC_ELS(vec)[0] = v; - - v = explode_certs((Scheme_Stx *)stx, ht); - SCHEME_VEC_ELS(vec)[1] = v; - v = explode_wraps(((Scheme_Stx *)stx)->wraps, ht); - SCHEME_VEC_ELS(vec)[2] = v; - - return vec; -} - -/**********************************************************************/ - -static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj) -{ - Scheme_Object *vec; - int i; - - vec = scheme_make_vector(8, NULL); - for (i = 0; i < 8; i++) { - SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; - } - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) - SCHEME_VEC_ELS(vec)[7] = scheme_true; - - return vec; -} - -static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj, Scheme_Object *insp) -{ - Scheme_Object *vec; - int i; - - if (!SCHEME_VECTORP(obj) - || (SCHEME_VEC_SIZE(obj) != 8)) - return NULL; - - vec = scheme_make_vector(8, NULL); - for (i = 0; i < 8; i++) { - SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; - } - - if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) - SCHEME_VEC_ELS(vec)[7] = insp; - - vec->type = scheme_free_id_info_type; - - return vec; -} - -/**********************************************************************/ - -#ifdef MZ_PRECISE_GC - -START_XFORM_SKIP; - -#define MARKS_FOR_STXOBJ_C -#include "mzmark.c" - -static void register_traversers(void) -{ - GC_REG_TRAV(scheme_rename_table_type, mark_rename_table); - GC_REG_TRAV(scheme_rename_table_set_type, mark_rename_table_set); - GC_REG_TRAV(scheme_rt_srcloc, mark_srcloc); - GC_REG_TRAV(scheme_wrap_chunk_type, mark_wrapchunk); - GC_REG_TRAV(scheme_certifications_type, mark_cert); - GC_REG_TRAV(scheme_lexical_rib_type, lex_rib); - GC_REG_TRAV(scheme_free_id_info_type, mark_free_id_info); -} - -END_XFORM_SKIP; - -#endif diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 78d53a686c..dd9873b571 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -1,8 +1,8 @@ /* Racket Copyright (c) 2004-2011 PLT Scheme Inc. - Copyright (c) 1995-2001 Matthew Flatt - + Copyright (c) 2000-2001 Matthew Flatt + This library is free software; you can redistribute it and/or modify it under the terms of the GNU Library General Public License as published by the Free Software Foundation; either @@ -19,7162 +19,9373 @@ Boston, MA 02110-1301 USA. */ -/* This file implements most of the built-in syntactic forms, except - the module-related forms (which are in module.c) and certain - aspects of the most primitive forms, such as application (handled - in eval.c) and functions (in fun.c). - - A primitive syntactic form consists of an expander, called by - `expand' and related functions, and a compiler, used by `compile' - and `eval'. (Compilation does *not* expand primitive forms first, - but instead peforms any necessary expansion directly.) */ - #include "schpriv.h" #include "schmach.h" #include "schexpobs.h" -/* globals */ -READ_ONLY Scheme_Object *scheme_define_values_syntax; -READ_ONLY Scheme_Object *scheme_define_syntaxes_syntax; -READ_ONLY Scheme_Object *scheme_ref_syntax; -READ_ONLY Scheme_Object *scheme_begin_syntax; -READ_ONLY Scheme_Object *scheme_lambda_syntax; -READ_ONLY Scheme_Object *scheme_compiled_void_code; -READ_ONLY Scheme_Object scheme_undefined[1]; +/* The implementation of syntax objects is extremely complex due to + two levels of optimization: -/* symbols */ -ROSYM static Scheme_Object *lambda_symbol; -ROSYM static Scheme_Object *letrec_values_symbol; -ROSYM static Scheme_Object *let_star_values_symbol; -ROSYM static Scheme_Object *let_values_symbol; -ROSYM static Scheme_Object *begin_symbol; -ROSYM static Scheme_Object *disappeared_binding_symbol; + 1. Different kinds of binding are handled in different ways, + because they'll have different usage patterns. For example, + module-level bindings are handled differently than local + bindings, because modules can't be nested. + + 2. To save time and space, the data structures involved have lots + of caches, and syntax objects to be marshaled undergo a + simplification pass. + + In addition, the need to marshal syntax objects to bytecode + introduces some other complications. */ + +ROSYM static Scheme_Object *source_symbol; /* uninterned! */ +ROSYM static Scheme_Object *share_symbol; /* uninterned! */ +ROSYM static Scheme_Object *origin_symbol; +ROSYM static Scheme_Object *lexical_symbol; +ROSYM static Scheme_Object *protected_symbol; +ROSYM static Scheme_Object *nominal_id_symbol; + +READ_ONLY static Scheme_Stx_Srcloc *empty_srcloc; +READ_ONLY static Scheme_Object *empty_simplified; +READ_ONLY static Scheme_Object *no_nested_inactive_certs; +READ_ONLY static Scheme_Object *no_nested_active_certs; +READ_ONLY static Scheme_Object *no_nested_certs; + +THREAD_LOCAL_DECL(static Scheme_Object *nominal_ipair_cache); +THREAD_LOCAL_DECL(static Scheme_Object *mark_id); +THREAD_LOCAL_DECL(static Scheme_Object *current_rib_timestamp); +THREAD_LOCAL_DECL(static Scheme_Hash_Table *quick_hash_table); +THREAD_LOCAL_DECL(static Scheme_Object *last_phase_shift); +THREAD_LOCAL_DECL(static Scheme_Object *unsealed_dependencies); +THREAD_LOCAL_DECL(static Scheme_Hash_Table *id_marks_ht); /* a cache */ +THREAD_LOCAL_DECL(static Scheme_Hash_Table *than_id_marks_ht); /* a cache */ +THREAD_LOCAL_DECL(static Scheme_Bucket_Table *interned_skip_ribs); -/* locals */ -static Scheme_Object *lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *ref_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *quote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *if_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *set_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *case_lambda_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_values_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *begin0_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *stratified_body_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *stratified_body_expand (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *syntax_p(int argc, Scheme_Object **argv); -static Scheme_Object *unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv); +static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv); -static Scheme_Object *with_cont_mark_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *syntax_line(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_col(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_span(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_src(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv); -static Scheme_Object *quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); -static Scheme_Object *letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec); -static Scheme_Object *letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec); +static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_property(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv); -static Scheme_Object *expand_lam(int argc, Scheme_Object **argv); +static Scheme_Object *bound_eq(int argc, Scheme_Object **argv); +static Scheme_Object *module_eq(int argc, Scheme_Object **argv); +static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv); +static Scheme_Object *module_templ_eq(int argc, Scheme_Object **argv); +static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv); +static Scheme_Object *module_binding(int argc, Scheme_Object **argv); +static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv); +static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv); +static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv); +static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv); +static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv); +static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv); -static Scheme_Object *write_let_value(Scheme_Object *obj); -static Scheme_Object *read_let_value(Scheme_Object *obj); -static Scheme_Object *write_let_void(Scheme_Object *obj); -static Scheme_Object *read_let_void(Scheme_Object *obj); -static Scheme_Object *write_letrec(Scheme_Object *obj); -static Scheme_Object *read_letrec(Scheme_Object *obj); -static Scheme_Object *write_let_one(Scheme_Object *obj); -static Scheme_Object *read_let_one(Scheme_Object *obj); -static Scheme_Object *write_top(Scheme_Object *obj); -static Scheme_Object *read_top(Scheme_Object *obj); -static Scheme_Object *write_case_lambda(Scheme_Object *obj); -static Scheme_Object *read_case_lambda(Scheme_Object *obj); +static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv); -static Scheme_Object *read_define_values(Scheme_Object *obj); -static Scheme_Object *write_define_values(Scheme_Object *obj); -static Scheme_Object *read_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *write_define_syntaxes(Scheme_Object *obj); -static Scheme_Object *read_define_for_syntax(Scheme_Object *obj); -static Scheme_Object *write_define_for_syntax(Scheme_Object *obj); -static Scheme_Object *read_set_bang(Scheme_Object *obj); -static Scheme_Object *write_set_bang(Scheme_Object *obj); -static Scheme_Object *read_boxenv(Scheme_Object *obj); -static Scheme_Object *write_boxenv(Scheme_Object *obj); -static Scheme_Object *read_varref(Scheme_Object *obj); -static Scheme_Object *write_varref(Scheme_Object *obj); -static Scheme_Object *read_apply_values(Scheme_Object *obj); -static Scheme_Object *write_apply_values(Scheme_Object *obj); +static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active); + +static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj); +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj, Scheme_Object *insp); #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif -#define cons(a,b) scheme_make_pair(a,b) +static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark); +static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks); +static struct Scheme_Cert *cons_cert(Scheme_Object *mark, Scheme_Object *modidx, + Scheme_Object *insp, Scheme_Object *key, + struct Scheme_Cert *next_cert); +static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int len); +static void preemptive_chunk(Scheme_Stx *stx); -#define max(a, b) (((a) > (b)) ? (a) : (b)) +#define CONS scheme_make_pair +#define ICONS scheme_make_pair -#define MAX_PROC_INLINE_SIZE 256 +#define HAS_SUBSTX(obj) (SCHEME_PAIRP(obj) || SCHEME_VECTORP(obj) || SCHEME_BOXP(obj) || prefab_p(obj) || SCHEME_HASHTRP(obj)) +#define HAS_CHAPERONE_SUBSTX(obj) (HAS_SUBSTX(obj) || (SCHEME_NP_CHAPERONEP(obj) && HAS_SUBSTX(SCHEME_CHAPERONE_VAL(obj)))) -/**********************************************************************/ -/* initialization */ -/**********************************************************************/ +XFORM_NONGCING static int prefab_p(Scheme_Object *o) +{ + if (SCHEME_STRUCTP(o)) { + if (((Scheme_Structure *)o)->stype->prefab_key) + if (MZ_OPT_HASH_KEY(&((Scheme_Structure *)o)->stype->iso) & STRUCT_TYPE_ALL_IMMUTABLE) + return 1; + } + return 0; +} -void -scheme_init_syntax (Scheme_Env *env) +#define STX_KEY(stx) MZ_OPT_HASH_KEY(&(stx)->iso) + +typedef struct Module_Renames { + Scheme_Object so; /* scheme_rename_table_type */ + char kind, needs_unmarshal; + char sealed; /* 1 means bound won't change; 2 means unbound won't change, either */ + Scheme_Object *phase; + Scheme_Object *set_identity; + Scheme_Hash_Table *ht; /* localname -> modidx OR + (cons modidx exportname) OR + (cons modidx nominal_modidx) OR + (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR + (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) OR + (cons insp localname) OR + (cons (cons insp insp) localname) + nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase) + import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */ + Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */ + Scheme_Object *shared_pes; /* list of (cons modidx (cons phase_export phase_and_marks)) + phase_and_marks -> phase-index-int OR + (cons (nonempty-listof mark) phase-index-int) + like nomarshal ht, but shared from provider */ + Scheme_Hash_Table *marked_names; /* shared with module environment while compiling the module; + this table maps a top-level-bound identifier with a non-empty mark + set to a gensym created for the binding */ + Scheme_Object *unmarshal_info; /* stores some renamings as information needed to consult + imported modules and restore renames from their exports */ + Scheme_Hash_Table *free_id_renames; /* like `ht', but only for free-id=? checking, + and targets can also include: + id => resolve id (but cache if possible; never appears after simplifying) + (box (cons sym #f)) => top-level binding + (box (cons sym sym)) => lexical binding */ +} Module_Renames; + +static void unmarshal_rename(Module_Renames *mrn, + Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, + Scheme_Hash_Table *export_registry); + +typedef struct Module_Renames_Set { + Scheme_Object so; /* scheme_rename_table_set_type */ + char kind, sealed; + Scheme_Object *set_identity; + Module_Renames *rt, *et; + Scheme_Hash_Table *other_phases; + Scheme_Object *share_marked_names; /* a Module_Renames_Set */ +} Module_Renames_Set; + +typedef struct Scheme_Cert { + Scheme_Inclhash_Object iso; + Scheme_Object *mark; + Scheme_Object *modidx; + Scheme_Object *insp; + Scheme_Object *key; + Scheme_Object *mapped; /* Indicates which mark+key combinations are in + this chain. The table is created for every 16 + items in the list. For a power of 2, all items + in the rest of the chain are in the table, and + the "next" pointer is NULL. For 2^n + 2^m, then + 2^m items are in the table, and so on. Overall, the + chain's total size if O(n * lg n) for a chain of + length n, and lookup for a mark+key pair is + O(lg n). */ + int depth; + struct Scheme_Cert *next; +} Scheme_Cert; + +#define CERT_NO_KEY(c) (MZ_OPT_HASH_KEY(&(c)->iso) & 0x1) +#define CERT_SET_NO_KEY(c) (MZ_OPT_HASH_KEY(&(c)->iso) |= 0x1) + +/* Certs encoding: + - NULL: no inactive or active certs; + maybe inactive certs in nested parts + - rcons(c1, c2): active certs c1 (maybe NULL), inactive certs c2 (maybe NULL); + maybe inactive certs in nested parts + Use flags 0x1 and 02 to indicate no inactive or active certs in nested parts */ +#define ACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CAR((stx)->certs) : (stx)->certs) : NULL)) +#define INACTIVE_CERTS(stx) ((Scheme_Cert *)((stx)->certs ? (SCHEME_RPAIRP((stx)->certs) ? SCHEME_CDR((stx)->certs) : NULL) : NULL)) +static Scheme_Object *stx_strip_certs(Scheme_Object *o, Scheme_Cert **cp, int active); + +#define SCHEME_NO_INACTIVE_SUBS_P(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1) +#define SCHEME_NO_ACTIVE_SUBS_P(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x2) +#define SCHEME_SET_NO_X_SUBS(obj, flag) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= flag) +#define SCHEME_SET_NO_INACTIVE_SUBS(obj) SCHEME_SET_NO_X_SUBS(obj, 0x1) +#define SCHEME_SET_NO_ACTIVE_SUBS(obj) SCHEME_SET_NO_X_SUBS(obj, 0x2) + +#define SCHEME_RENAME_LEN(vec) ((SCHEME_VEC_SIZE(vec) - 2) >> 1) + +typedef struct Scheme_Lexical_Rib { + Scheme_Object so; + Scheme_Object *rename; /* a vector for a lexical rename */ + Scheme_Object *timestamp; + int *sealed; + Scheme_Object *mapped_names; /* only in the initial link; int or hash table */ + struct Scheme_Lexical_Rib *next; +} Scheme_Lexical_Rib; + +#define SCHEME_RENAMESP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_type)) +#define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type)) + +#define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) +#define SCHEME_RIB_DELIMP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rib_delimiter_type)) + +#define SCHEME_PRUNEP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_prune_context_type)) + +XFORM_NONGCING static int is_member(Scheme_Object *a, Scheme_Object *l) +{ + while (SCHEME_PAIRP(l)) { + if (SAME_OBJ(a, SCHEME_CAR(l))) + return 1; + l = SCHEME_CDR(l); + } + return 0; +} + +static int is_rename_inspector_info(Scheme_Object *v) +{ + return (SAME_TYPE(SCHEME_TYPE(v), scheme_inspector_type) + || (SCHEME_PAIRP(v) + && SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_inspector_type) + && SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(v)), scheme_inspector_type))); +} + +/* Wraps: + + A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a + "vector" (a scheme_wrap_chunk_type) of wrap-elems. + + Each wrap-elem has one of several shapes: + + - A wrap-elem <+num> is a mark + + - A wrap-elem <-num> is a certificate-only mark (doesn't conttribute to + id equivalence) + + - A wrap-elem (vector ..._0 ..._0) is a lexical rename + env (sym var : + ->pos) void => not yet computed + or #f sym => var-resolved is answer to replace #f + for nozero skipped ribs + (rlistof (rcons skipped sym)) => generalization of sym + (mcons var-resolved next) => depends on unsealed rib, + will be cleared when rib set + or: + (cons (cons )) => + free-id=? renaming to on match + - A wrap-elem (vector ..._0 ..._0) is also a lexical rename + bool var resolved: sym or (cons ), + where is module/lexical binding info: + (cons #f) => top-level binding + (cons ) => lexical binding + (free-eq-info ...) => module-binding + where the variables have already been resolved and filtered (no mark + or lexical-env comparison needed with the remaining wraps) + + - A wrap-elem (make-rib vector rib) + is an extensible set of lexical renames; it is the same as + having the vectors inline in place of the rib, except that + new vectors can be added imperatively; simplification turns this + into a vector + + - A wrap-elem (make-rib-delimiter ) + appears in pairs around rib elements; the deeper is just a + bracket, while the shallow one contains a non-empty list of + ribs; for each environment name defined within the set of + ribs, no rib within the set can build on a binding to that + environment past the end delimiter; this is used by `local-expand' + when given a list of ribs, and simplifcation eliminates + rib delimiters + + - A wrap-elem (make-prune ) + restricts binding information to that relevant for + as a datum + + - A wrap-elem is a module rename set + the hash table maps renamed syms to modname-srcname pairs + + - A wrap-elem is a set of s for + different phases. + + - A wrap-elem is a chain-specific cache; it maps + identifiers to #t, and 0 to a deeper part of the chain; a + resolution for an identifier can safely skip to the deeper + part if the identifer does not have a mapping; this skips + simple lexical renames (not ribs) and marks, only, and it's + inserted into a chain heuristically + + - A wrap-elem (box (vector )) + is a phase shift by , remapping the first to the + second ; the part is for finding + modules to unmarshal import renamings + + [Don't add a pair case, because sometimes we test for element + versus list-of-element.] + + The lazy_prefix field of a syntax object keeps track of how many of + the first wraps (items and chunks in the list) need to be propagated + to sub-syntax. */ + +#define IS_POSMARK(x) (SCHEME_INTP(x) ? (SCHEME_INT_VAL(x) >= 0) : SCHEME_BIGPOS(x)) +#define SCHEME_MARKP(x) (SCHEME_INTP(x) || SCHEME_BIGNUMP(x)) + +XFORM_NONGCING static int nom_mod_p(Scheme_Object *p) +{ + p = SCHEME_CDR(p); + return !SCHEME_PAIRP(p) && !SCHEME_SYMBOLP(p); +} + +/*========================================================================*/ +/* wrap chunks */ +/*========================================================================*/ + +typedef struct { + Scheme_Type type; + mzshort len; + Scheme_Object *a[1]; +} Wrap_Chunk; + +#define MALLOC_WRAP_CHUNK(n) (Wrap_Chunk *)scheme_malloc_tagged(sizeof(Wrap_Chunk) + ((n - 1) * sizeof(Scheme_Object *))) + +/* Macros for iterating over the elements of a wrap. */ + +typedef struct { + Scheme_Object *l; + Scheme_Object *a; + int is_limb; + int pos; +} Wrap_Pos; + +XFORM_NONGCING static void WRAP_POS_SET_FIRST(Wrap_Pos *w) +{ + if (!SCHEME_NULLP(w->l)) { + Scheme_Object *a; + a = SCHEME_CAR(w->l); + if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { + w->is_limb = 1; + w->pos = 0; + w->a = ((Wrap_Chunk *)a)->a[0]; + } else { + w->is_limb = 0; + w->a = a; + } + } + /* silence gcc "may be used uninitialized in this function" warnings */ + else { + w->a = NULL; + w->is_limb = 0; + } +} + +XFORM_NONGCING static MZ_INLINE void DO_WRAP_POS_INC(Wrap_Pos *w) +{ + Scheme_Object *a; + if (w->is_limb && (w->pos + 1 < ((Wrap_Chunk *)SCHEME_CAR(w->l))->len)) { + a = SCHEME_CAR(w->l); + w->pos++; + w->a = ((Wrap_Chunk *)a)->a[w->pos]; + } else { + w->l = SCHEME_CDR(w->l); + if (!SCHEME_NULLP(w->l)) { + a = SCHEME_CAR(w->l); + if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { + w->is_limb = 1; + w->pos = 0; + w->a = ((Wrap_Chunk *)a)->a[0]; + } else { + w->is_limb = 0; + w->a = a; + } + } else + w->is_limb = 0; + } +} + +#define WRAP_POS Wrap_Pos +#define WRAP_POS_INIT(w, wr) w.l = wr; WRAP_POS_SET_FIRST(&w) + +#define WRAP_POS_INC(w) DO_WRAP_POS_INC(&w) + +#define WRAP_POS_INIT_END(w) (w.l = scheme_null, w.a = NULL, w.is_limb = 0, w.pos = 0) +#define WRAP_POS_END_P(w) SCHEME_NULLP(w.l) +#define WRAP_POS_FIRST(w) w.a +#define WRAP_POS_COPY(w, w2) w.l = (w2).l; w.a = (w2).a; w.is_limb= (w2).is_limb; w.pos = (w2).pos + +/* Walking backwards through one chunk: */ + +XFORM_NONGCING static void DO_WRAP_POS_REVINIT(Wrap_Pos *w, Scheme_Object *k) +{ + Scheme_Object *a; + a = SCHEME_CAR(k); + if (SCHEME_TYPE(a) == scheme_wrap_chunk_type) { + w->is_limb = 1; + w->l = k; + w->pos = ((Wrap_Chunk *)a)->len - 1; + w->a = ((Wrap_Chunk *)a)->a[w->pos]; + } else { + w->l = k; + w->a = a; + w->is_limb = 0; + w->pos = 0; + } +} + +#define WRAP_POS_KEY(w) w.l +#define WRAP_POS_REVINIT(w, k) DO_WRAP_POS_REVINIT(&w, k) +#define WRAP_POS_REVEND_P(w) (w.pos < 0) +#define WRAP_POS_DEC(w) --w.pos; if (w.pos >= 0) w.a = ((Wrap_Chunk *)SCHEME_CAR(w.l))->a[w.pos] + +#define WRAP_POS_PLAIN_TAIL(w) (w.is_limb ? (w.pos ? NULL : w.l) : w.l) + +/*========================================================================*/ +/* initialization */ +/*========================================================================*/ + +void scheme_init_stx(Scheme_Env *env) { #ifdef MZ_PRECISE_GC register_traversers(); #endif - REGISTER_SO(scheme_define_values_syntax); - REGISTER_SO(scheme_define_syntaxes_syntax); - REGISTER_SO(scheme_lambda_syntax); - REGISTER_SO(scheme_begin_syntax); - REGISTER_SO(scheme_compiled_void_code); + GLOBAL_FOLDING_PRIM_UNARY_INLINED("syntax?", syntax_p, 1, 1, 1, env); - REGISTER_SO(lambda_symbol); - REGISTER_SO(letrec_values_symbol); - REGISTER_SO(let_star_values_symbol); - REGISTER_SO(let_values_symbol); - REGISTER_SO(begin_symbol); - REGISTER_SO(disappeared_binding_symbol); - - scheme_undefined->type = scheme_undefined_type; + GLOBAL_FOLDING_PRIM("syntax->datum", syntax_to_datum, 1, 1, 1, env); + GLOBAL_FOLDING_PRIM("datum->syntax", datum_to_syntax, 2, 5, 1, env); - lambda_symbol = scheme_intern_symbol("lambda"); + GLOBAL_FOLDING_PRIM_UNARY_INLINED("syntax-e", scheme_checked_syntax_e, 1, 1, 1, env); - letrec_values_symbol = scheme_intern_symbol("letrec-values"); - let_star_values_symbol = scheme_intern_symbol("let*-values"); - let_values_symbol = scheme_intern_symbol("let-values"); + GLOBAL_FOLDING_PRIM("syntax-line" , syntax_line , 1, 1, 1, env); + GLOBAL_FOLDING_PRIM("syntax-column" , syntax_col , 1, 1, 1, env); + GLOBAL_FOLDING_PRIM("syntax-position", syntax_pos , 1, 1, 1, env); + GLOBAL_FOLDING_PRIM("syntax-span" , syntax_span , 1, 1, 1, env); + GLOBAL_FOLDING_PRIM("syntax-source" , syntax_src , 1, 1, 1, env); + GLOBAL_FOLDING_PRIM("syntax->list" , syntax_to_list, 1, 1, 1, env); - begin_symbol = scheme_intern_symbol("begin"); - disappeared_binding_symbol = scheme_intern_symbol("disappeared-binding"); + GLOBAL_IMMED_PRIM("syntax-original?" , syntax_original_p , 1, 1, env); + GLOBAL_IMMED_PRIM("syntax-property" , syntax_property , 2, 3, env); + GLOBAL_IMMED_PRIM("syntax-property-symbol-keys" , syntax_property_keys , 1, 1, env); - scheme_install_type_writer(scheme_let_value_type, write_let_value); - scheme_install_type_reader(scheme_let_value_type, read_let_value); - scheme_install_type_writer(scheme_let_void_type, write_let_void); - scheme_install_type_reader(scheme_let_void_type, read_let_void); - scheme_install_type_writer(scheme_letrec_type, write_letrec); - scheme_install_type_reader(scheme_letrec_type, read_letrec); - scheme_install_type_writer(scheme_let_one_type, write_let_one); - scheme_install_type_reader(scheme_let_one_type, read_let_one); - scheme_install_type_writer(scheme_case_lambda_sequence_type, write_case_lambda); - scheme_install_type_reader(scheme_case_lambda_sequence_type, read_case_lambda); + GLOBAL_IMMED_PRIM("syntax-track-origin" , syntax_track_origin , 3, 3, env); - scheme_install_type_writer(scheme_define_values_type, write_define_values); - scheme_install_type_reader(scheme_define_values_type, read_define_values); - scheme_install_type_writer(scheme_define_syntaxes_type, write_define_syntaxes); - scheme_install_type_reader(scheme_define_syntaxes_type, read_define_syntaxes); - scheme_install_type_writer(scheme_define_for_syntax_type, write_define_for_syntax); - scheme_install_type_reader(scheme_define_for_syntax_type, read_define_for_syntax); - scheme_install_type_writer(scheme_set_bang_type, write_set_bang); - scheme_install_type_reader(scheme_set_bang_type, read_set_bang); - scheme_install_type_writer(scheme_boxenv_type, write_boxenv); - scheme_install_type_reader(scheme_boxenv_type, read_boxenv); - scheme_install_type_writer(scheme_varref_form_type, write_varref); - scheme_install_type_reader(scheme_varref_form_type, read_varref); - scheme_install_type_writer(scheme_apply_values_type, write_apply_values); - scheme_install_type_reader(scheme_apply_values_type, read_apply_values); + GLOBAL_IMMED_PRIM("make-syntax-delta-introducer" , scheme_syntax_make_transfer_intro, 2, 3, env); - scheme_install_type_writer(scheme_compilation_top_type, write_top); - scheme_install_type_reader(scheme_compilation_top_type, read_top); + GLOBAL_IMMED_PRIM("bound-identifier=?" , bound_eq , 2, 3, env); + GLOBAL_IMMED_PRIM("free-identifier=?" , module_eq , 2, 3, env); + GLOBAL_IMMED_PRIM("free-transformer-identifier=?" , module_trans_eq , 2, 2, env); + GLOBAL_IMMED_PRIM("free-template-identifier=?" , module_templ_eq , 2, 2, env); + GLOBAL_IMMED_PRIM("free-label-identifier=?" , module_label_eq , 2, 2, env); - scheme_define_values_syntax = scheme_make_compiled_syntax(define_values_syntax, - define_values_expand); - scheme_define_syntaxes_syntax = scheme_make_compiled_syntax(define_syntaxes_syntax, - define_syntaxes_expand); - scheme_lambda_syntax = scheme_make_compiled_syntax(lambda_syntax, - lambda_expand); - scheme_begin_syntax = scheme_make_compiled_syntax(begin_syntax, - begin_expand); - - scheme_add_global_keyword("lambda", - scheme_lambda_syntax, - env); - { - /* Graak lambda binding: */ - Scheme_Object *macro, *fn; + GLOBAL_IMMED_PRIM("identifier-binding" , module_binding , 1, 2, env); + GLOBAL_IMMED_PRIM("identifier-transformer-binding" , module_trans_binding , 1, 2, env); + GLOBAL_IMMED_PRIM("identifier-template-binding" , module_templ_binding , 1, 1, env); + GLOBAL_IMMED_PRIM("identifier-label-binding" , module_label_binding , 1, 1, env); + GLOBAL_IMMED_PRIM("identifier-prune-lexical-context" , identifier_prune , 1, 2, env); + GLOBAL_IMMED_PRIM("identifier-prune-to-source-module", identifier_prune_to_module, 1, 1, env); - fn = scheme_make_prim_w_arity(expand_lam, "\316\273", 1, 1); - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = fn; - scheme_add_global_keyword("\316\273", macro, env); - } - scheme_add_global_keyword("define-values", scheme_define_values_syntax, env); - scheme_add_global_keyword("quote", - scheme_make_compiled_syntax(quote_syntax, - quote_expand), - env); - scheme_add_global_keyword("if", - scheme_make_compiled_syntax(if_syntax, - if_expand), - env); - scheme_add_global_keyword("set!", - scheme_make_compiled_syntax(set_syntax, - set_expand), - env); - scheme_add_global_keyword("#%variable-reference", - scheme_make_compiled_syntax(ref_syntax, - ref_expand), - env); + GLOBAL_NONCM_PRIM("syntax-source-module" , syntax_src_module , 1, 2, env); + GLOBAL_IMMED_PRIM("syntax-recertify" , syntax_recertify , 4, 4, env); - scheme_add_global_keyword("#%expression", - scheme_make_compiled_syntax(expression_syntax, - expression_expand), - env); + REGISTER_SO(source_symbol); + REGISTER_SO(share_symbol); + REGISTER_SO(origin_symbol); + REGISTER_SO(lexical_symbol); + REGISTER_SO(protected_symbol); + REGISTER_SO(nominal_id_symbol); + source_symbol = scheme_make_symbol("source"); /* not interned! */ + share_symbol = scheme_make_symbol("share"); /* not interned! */ + origin_symbol = scheme_intern_symbol("origin"); + lexical_symbol = scheme_intern_symbol("lexical"); + protected_symbol = scheme_intern_symbol("protected"); + nominal_id_symbol = scheme_intern_symbol("nominal-id"); - scheme_add_global_keyword("case-lambda", - scheme_make_compiled_syntax(case_lambda_syntax, - case_lambda_expand), - env); + REGISTER_SO(mark_id); + REGISTER_SO(current_rib_timestamp); + mark_id = scheme_make_integer(0); + current_rib_timestamp = scheme_make_integer(0); - scheme_add_global_keyword("let-values", - scheme_make_compiled_syntax(let_values_syntax, - let_values_expand), - env); - scheme_add_global_keyword("let*-values", - scheme_make_compiled_syntax(let_star_values_syntax, - let_star_values_expand), - env); - scheme_add_global_keyword("letrec-values", - scheme_make_compiled_syntax(letrec_values_syntax, - letrec_values_expand), - env); - - scheme_add_global_keyword("begin", - scheme_begin_syntax, - env); - scheme_add_global_keyword("#%stratified-body", - scheme_make_compiled_syntax(stratified_body_syntax, - stratified_body_expand), - env); + REGISTER_SO(empty_srcloc); + empty_srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); +#ifdef MZTAG_REQUIRED + empty_srcloc->type = scheme_rt_srcloc; +#endif + empty_srcloc->src = scheme_false; + empty_srcloc->line = -1; + empty_srcloc->col = -1; + empty_srcloc->pos = -1; - scheme_add_global_keyword("begin0", - scheme_make_compiled_syntax(begin0_syntax, - begin0_expand), - env); + REGISTER_SO(empty_simplified); + empty_simplified = scheme_make_vector(2, scheme_false); - scheme_add_global_keyword("unquote", - scheme_make_compiled_syntax(unquote_syntax, - unquote_expand), - env); - scheme_add_global_keyword("unquote-splicing", - scheme_make_compiled_syntax(unquote_syntax, - unquote_expand), - env); + REGISTER_SO(no_nested_inactive_certs); + REGISTER_SO(no_nested_active_certs); + REGISTER_SO(no_nested_certs); + no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL); + no_nested_active_certs = scheme_make_raw_pair(NULL, NULL); + no_nested_certs = scheme_make_raw_pair(NULL, NULL); + SCHEME_SET_NO_INACTIVE_SUBS(no_nested_inactive_certs); + SCHEME_SET_NO_ACTIVE_SUBS(no_nested_active_certs); + SCHEME_SET_NO_INACTIVE_SUBS(no_nested_certs); + SCHEME_SET_NO_ACTIVE_SUBS(no_nested_certs); - scheme_add_global_keyword("with-continuation-mark", - scheme_make_compiled_syntax(with_cont_mark_syntax, - with_cont_mark_expand), - env); - - scheme_add_global_keyword("quote-syntax", - scheme_make_compiled_syntax(quote_syntax_syntax, - quote_syntax_expand), - env); - scheme_add_global_keyword("define-syntaxes", scheme_define_syntaxes_syntax, env); - scheme_add_global_keyword("define-values-for-syntax", - scheme_make_compiled_syntax(define_for_syntaxes_syntax, - define_for_syntaxes_expand), - env); - scheme_add_global_keyword("letrec-syntaxes+values", - scheme_make_compiled_syntax(letrec_syntaxes_syntax, - letrec_syntaxes_expand), - env); + scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); + scheme_install_type_reader2(scheme_free_id_info_type, read_free_id_info_prefix); } -Scheme_Object * -scheme_make_compiled_syntax(Scheme_Syntax *proc, - Scheme_Syntax_Expander *eproc) -{ - Scheme_Object *syntax; - - syntax = scheme_alloc_eternal_object(); - syntax->type = scheme_syntax_compiler_type; - SCHEME_SYNTAX(syntax) = (Scheme_Object *)proc; - SCHEME_SYNTAX_EXP(syntax) = (Scheme_Object *)eproc; - - return syntax; -} - -/**********************************************************************/ -/* utilities */ -/**********************************************************************/ - -static int check_form(Scheme_Object *form, Scheme_Object *base_form) -{ - int i; - - for (i = 0; SCHEME_STX_PAIRP(form); i++) { - form = SCHEME_STX_CDR(form); +void scheme_init_stx_places(int initial_main_os_thread) { + REGISTER_SO(last_phase_shift); + REGISTER_SO(nominal_ipair_cache); + REGISTER_SO(quick_hash_table); + REGISTER_SO(id_marks_ht); + REGISTER_SO(than_id_marks_ht); + REGISTER_SO(interned_skip_ribs); + REGISTER_SO(unsealed_dependencies); + + if (!initial_main_os_thread) { + REGISTER_SO(mark_id); + REGISTER_SO(current_rib_timestamp); + mark_id = scheme_make_integer(0); + current_rib_timestamp = scheme_make_integer(0); } - if (!SCHEME_STX_NULLP(form)) { - scheme_wrong_syntax(NULL, form, base_form, "bad syntax (" IMPROPER_LIST_FORM ")"); + interned_skip_ribs = scheme_make_weak_equal_table(); +} + +/*========================================================================*/ +/* stx creation and maintenance */ +/*========================================================================*/ + +Scheme_Object *scheme_make_stx(Scheme_Object *val, + Scheme_Stx_Srcloc *srcloc, + Scheme_Object *props) +{ + Scheme_Stx *stx; + + stx = MALLOC_ONE_TAGGED(Scheme_Stx); + stx->iso.so.type = scheme_stx_type; + STX_KEY(stx) = HAS_SUBSTX(val) ? STX_SUBSTX_FLAG : 0; + stx->val = val; + stx->srcloc = srcloc; + stx->wraps = scheme_null; + stx->props = props; + + return (Scheme_Object *)stx; +} + +Scheme_Object *scheme_make_stx_w_offset(Scheme_Object *val, + intptr_t line, intptr_t col, intptr_t pos, intptr_t span, + Scheme_Object *src, + Scheme_Object *props) +{ + Scheme_Stx_Srcloc *srcloc; + + srcloc = MALLOC_ONE_RT(Scheme_Stx_Srcloc); +#ifdef MZTAG_REQUIRED + srcloc->type = scheme_rt_srcloc; +#endif + srcloc->src = src; + srcloc->line = line; + srcloc->col = col; + srcloc->pos = pos; + srcloc->span = span; + + return scheme_make_stx(val, srcloc, props); +} + +Scheme_Object *scheme_make_renamed_stx(Scheme_Object *sym, + Scheme_Object *rn) +{ + Scheme_Object *stx; + + stx = scheme_make_stx(sym, empty_srcloc, NULL); + + if (rn) { + rn = scheme_make_pair(rn, scheme_null); + ((Scheme_Stx *)stx)->wraps = rn; } - return i; + return stx; } -static void bad_form(Scheme_Object *form, int l) -{ - scheme_wrong_syntax(NULL, NULL, form, - "bad syntax (has %d part%s after keyword)", - l - 1, (l != 2) ? "s" : ""); -} - -Scheme_Object *scheme_check_name_property(Scheme_Object *code, Scheme_Object *current_val) +Scheme_Object *scheme_stx_track(Scheme_Object *naya, + Scheme_Object *old, + Scheme_Object *origin) + /* Maintain properties for an expanded expression */ { - Scheme_Object *name; + Scheme_Stx *nstx = (Scheme_Stx *)naya; + Scheme_Stx *ostx = (Scheme_Stx *)old; + Scheme_Object *ne, *oe, *e1, *e2; + Scheme_Object *certs; + Scheme_Object *wraps, *modinfo_cache; + intptr_t lazy_prefix; - name = scheme_stx_property(code, scheme_inferred_name_symbol, NULL); - if (name && SCHEME_SYMBOLP(name)) - return name; - else - return current_val; -} - -/**********************************************************************/ -/* lambda utils */ -/**********************************************************************/ - -static void lambda_check(Scheme_Object *form) -{ - if (SCHEME_STX_PAIRP(form) - && SCHEME_STX_PAIRP(SCHEME_STX_CDR(form))) { - Scheme_Object *rest; - rest = SCHEME_STX_CDR(form); - if (SCHEME_STX_PAIRP(SCHEME_STX_CDR(rest))) - return; - } - - scheme_wrong_syntax(NULL, NULL, form, NULL); -} - -static void lambda_check_args(Scheme_Object *args, Scheme_Object *form, Scheme_Comp_Env *env) -{ - Scheme_Object *v, *a; - DupCheckRecord r; - - if (!SCHEME_STX_SYMBOLP(args)) { - for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - a = SCHEME_STX_CAR(v); - scheme_check_identifier(NULL, a, NULL, env, form); - } - - if (!SCHEME_STX_NULLP(v)) { - if (!SCHEME_STX_SYMBOLP(v)) { - scheme_check_identifier(NULL, v, NULL, env, form); - } - } - - /* Check for duplicate names: */ - scheme_begin_dup_symbol_check(&r, env); - for (v = args; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *name; - - name = SCHEME_STX_CAR(v); - scheme_dup_symbol_check(&r, NULL, name, "argument", form); - } - if (!SCHEME_STX_NULLP(v)) { - scheme_dup_symbol_check(&r, NULL, v, "argument", form); - } - } -} - -static Scheme_Object * -lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *args; - - lambda_check(form); - - args = SCHEME_STX_CDR(form); - args = SCHEME_STX_CAR(args); - lambda_check_args(args, form, env); - - scheme_rec_add_certs(rec, drec, form); - - return scheme_make_closure_compilation(env, form, rec, drec); -} - -static Scheme_Object * -lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *args, *body, *fn; - Scheme_Comp_Env *newenv; - Scheme_Expand_Info erec1; - - SCHEME_EXPAND_OBSERVE_PRIM_LAMBDA(erec[drec].observer); - - lambda_check(form); + if (nstx->props) { + if (SAME_OBJ(nstx->props, STX_SRCTAG)) { + /* Retain 'source tag. */ + ne = ICONS(ICONS(source_symbol, scheme_true), scheme_null); + } else + ne = nstx->props; + } else + ne = scheme_null; - args = SCHEME_STX_CDR(form); - args = SCHEME_STX_CAR(args); - - lambda_check_args(args, form, env); - - scheme_rec_add_certs(erec, drec, form); - - newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs); - - body = SCHEME_STX_CDR(form); - body = SCHEME_STX_CDR(body); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = scheme_add_env_renames(body, newenv, env); - - args = scheme_add_env_renames(args, newenv, env); /* for re-expansion */ - SCHEME_EXPAND_OBSERVE_LAMBDA_RENAMES(erec[drec].observer, args, body); - - fn = SCHEME_STX_CAR(form); - - scheme_init_expand_recs(erec, drec, &erec1, 1); - erec1.value_name = scheme_false; - - return scheme_datum_to_syntax(cons(fn, - cons(args, - scheme_expand_block(body, - newenv, - &erec1, - 0))), - form, form, - 0, 2); -} - -static Scheme_Object *expand_lam(int argc, Scheme_Object **argv) -{ - Scheme_Object *form = argv[0], *args, *fn; - Scheme_Comp_Env *env; - - env = scheme_current_thread->current_local_env; - - lambda_check(form); - - args = SCHEME_STX_CDR(form); - args = SCHEME_STX_CAR(args); - - lambda_check_args(args, form, env); - - fn = SCHEME_STX_CAR(form); - fn = scheme_datum_to_syntax(lambda_symbol, fn, scheme_sys_wraps(env), 0, 0); - - args = SCHEME_STX_CDR(form); - return scheme_datum_to_syntax(cons(fn, args), form, fn, 0, 0); -} - -/**********************************************************************/ -/* define utils */ -/**********************************************************************/ - -void scheme_set_global_bucket(char *who, Scheme_Bucket *b, Scheme_Object *val, - int set_undef) -{ - if ((b->val || set_undef) - && ((b->so.type != scheme_variable_type) - || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_IMMUTATED)) - && (val || !(((Scheme_Bucket_With_Flags *)b)->flags & GLOB_IS_LINKED))) - b->val = val; - else { - Scheme_Env *home; - home = scheme_get_bucket_home(b); - if (home && home->module) { - const char *msg; - int is_set; - - if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) - msg = "%s: cannot %s: %S in module: %D"; - else - msg = "%s: cannot %s: %S"; - - is_set = !strcmp(who, "set!"); - - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key, - msg, - who, - (b->val - ? (!val - ? "undefine variable that is used by other modules" - : (is_set - ? "modify a constant" - : "re-define a constant")) - : "set variable before its definition"), - (Scheme_Object *)b->key, - home->module->modsrc); + if (ostx->props) { + if (SAME_OBJ(ostx->props, STX_SRCTAG)) { + /* Drop 'source, add 'origin. */ + oe = NULL; } else { - scheme_raise_exn(MZEXN_FAIL_CONTRACT_VARIABLE, b->key, - "%s: cannot %s variable: %S", - who, - (val - ? (b->val ? "change constant" : "set undefined") - : "undefine"), - (Scheme_Object *)b->key); - } - } -} + Scheme_Object *p, *a; + int mod = 0, add = 1; -void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v) -{ - Scheme_Object *macro; + oe = ostx->props; - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = v; + /* Drop 'source and 'share, add 'origin if not there */ + for (p = oe; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) { + a = SCHEME_CAR(SCHEME_CAR(p)); + if (SAME_OBJ(a, source_symbol) || SAME_OBJ(a, share_symbol)) + mod = 1; + else if (SAME_OBJ(a, origin_symbol)) + mod = 1; + } - b->val = macro; -} + if (mod) { + Scheme_Object *first = scheme_null, *last = NULL; -static Scheme_Object * -define_execute_with_dynamic_state(Scheme_Object *vec, int delta, int defmacro, - Resolve_Prefix *rp, Scheme_Env *dm_env, - Scheme_Dynamic_State *dyn_state) -{ - Scheme_Object *name, *macro, *vals_expr, *vals, *var; - int i, g, show_any; - Scheme_Bucket *b; - Scheme_Object **save_runstack = NULL; + for (; SCHEME_PAIRP(oe); oe = SCHEME_CDR(oe)) { + a = SCHEME_CAR(SCHEME_CAR(oe)); + if (!SAME_OBJ(a, source_symbol) && !SAME_OBJ(a, share_symbol)) { + if (!SAME_OBJ(a, origin_symbol)) { + p = ICONS(SCHEME_CAR(oe), scheme_null); + } else { + p = ICONS(ICONS(a, ICONS(origin, + SCHEME_CDR(SCHEME_CAR(oe)))), + scheme_null); + add = 0; + } - vals_expr = SCHEME_VEC_ELS(vec)[0]; - - if (dm_env) { - scheme_prepare_exp_env(dm_env); - - save_runstack = scheme_push_prefix(dm_env->exp_env, rp, NULL, NULL, 1, 1, NULL); - vals = scheme_eval_linked_expr_multi_with_dynamic_state(vals_expr, dyn_state); - if (defmacro == 2) - dm_env = NULL; - else - scheme_pop_prefix(save_runstack); - } else { - vals = _scheme_eval_linked_expr_multi(vals_expr); - dm_env = NULL; - } - - if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) { - Scheme_Object **values; - - i = SCHEME_VEC_SIZE(vec) - delta; - - g = scheme_current_thread->ku.multiple.count; - if (i == g) { - values = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; - if (SAME_OBJ(values, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - for (i = 0; i < g; i++) { - var = SCHEME_VEC_ELS(vec)[i+delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = values[i]; - - scheme_set_global_bucket("define-syntaxes", b, macro, 1); - scheme_shadow(dm_env, (Scheme_Object *)b->key, 0); - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - - scheme_set_global_bucket("define-values", b, values[i], 1); - scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1); - - if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; } } + + oe = first; + } + if (add) { + oe = ICONS(ICONS(origin_symbol, + ICONS(origin, scheme_null)), + oe); } - if (defmacro) - scheme_pop_prefix(save_runstack); - - return scheme_void; } + } else { + /* Add 'origin. */ + oe = NULL; + } - if (SAME_OBJ(scheme_current_thread->ku.multiple.array, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - } else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */ - var = SCHEME_VEC_ELS(vec)[delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); + if (!oe) + oe = ICONS(ICONS(origin_symbol, + ICONS(origin, scheme_null)), + scheme_null); - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - SCHEME_PTR_VAL(macro) = vals; - - scheme_set_global_bucket("define-syntaxes", b, macro, 1); - scheme_shadow(dm_env, (Scheme_Object *)b->key, 0); - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - - scheme_set_global_bucket("define-values", b, vals, 1); - scheme_shadow(scheme_get_bucket_home(b), (Scheme_Object *)b->key, 1); - - if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) { - int flags = GLOB_IS_IMMUTATED; - if (SCHEME_PROCP(vals_expr) - || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_unclosed_procedure_type) - || SAME_TYPE(SCHEME_TYPE(vals_expr), scheme_case_lambda_sequence_type)) - flags |= GLOB_IS_CONSISTENT; - ((Scheme_Bucket_With_Flags *)b)->flags |= flags; + /* Merge ne and oe (ne takes precedence). */ + + /* First, check for overlap: */ + for (e1 = ne; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) { + Scheme_Object *a; + a = SCHEME_CAR(SCHEME_CAR(e1)); + for (e2 = oe; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) { + if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) { + break; } - - if (defmacro) - scheme_pop_prefix(save_runstack); + } + if (!SCHEME_NULLP(e1)) + break; + } + + if (SCHEME_NULLP(e1)) { + /* Can just append props info (probably the common case). */ + if (!SCHEME_NULLP(oe)) + ne = scheme_append(ne, oe); + } else { + /* Have to perform an actual merge: */ + Scheme_Object *first = scheme_null, *last = NULL, *p; + + for (e1 = ne; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) { + Scheme_Object *a, *v; + a = SCHEME_CAR(SCHEME_CAR(e1)); + v = SCHEME_CDR(SCHEME_CAR(e1)); + for (e2 = oe; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) { + if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) { + v = ICONS(v, SCHEME_CDR(SCHEME_CAR(e2))); + break; + } + } + + p = ICONS(ICONS(a, v), scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; } - return scheme_void; - } else - g = 1; + for (e1 = oe; SCHEME_PAIRP(e1); e1 = SCHEME_CDR(e1)) { + Scheme_Object *a, *v; + a = SCHEME_CAR(SCHEME_CAR(e1)); + v = SCHEME_CDR(SCHEME_CAR(e1)); + for (e2 = ne; SCHEME_PAIRP(e2); e2 = SCHEME_CDR(e2)) { + if (SAME_OBJ(SCHEME_CAR(SCHEME_CAR(e2)), a)) { + v = NULL; + break; + } + } - /* Special handling of 0 values for define-syntaxes: - do nothing. This makes (define-values (a b c) (values)) - a kind of declaration form, which is useful is - a, b, or c is introduced by a macro. */ - if (dm_env && !g) - return scheme_void; - - i = SCHEME_VEC_SIZE(vec) - delta; - - show_any = i; - - if (show_any) { - var = SCHEME_VEC_ELS(vec)[delta]; - if (dm_env) { - b = scheme_global_keyword_bucket(var, dm_env); - name = (Scheme_Object *)b->key; - } else { - Scheme_Prefix *toplevels; - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(var)]; - name = (Scheme_Object *)b->key; + if (v) { + p = ICONS(ICONS(a, v), scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + } } - } else - name = NULL; + + ne = first; + } + + /* Clone nstx, keeping wraps, changing props to ne */ + + wraps = nstx->wraps; + if (STX_KEY(nstx) & STX_SUBSTX_FLAG) { + modinfo_cache = NULL; + lazy_prefix = nstx->u.lazy_prefix; + } else { + modinfo_cache = nstx->u.modinfo_cache; + lazy_prefix = 0; + } + + certs = nstx->certs; + + nstx = (Scheme_Stx *)scheme_make_stx(nstx->val, nstx->srcloc, ne); + + nstx->wraps = wraps; + if (modinfo_cache) + nstx->u.modinfo_cache = modinfo_cache; + else + nstx->u.lazy_prefix = lazy_prefix; + + nstx->certs = certs; + + return (Scheme_Object *)nstx; +} + +/******************** chain cache ********************/ + +static int maybe_add_chain_cache(Scheme_Stx *stx) +{ + WRAP_POS awl; + Scheme_Object *p; + int skipable = 0, pos = 1; + + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + + while (!WRAP_POS_END_P(awl)) { + /* Skip over renames, cancelled marks, and negative marks: */ + p = WRAP_POS_FIRST(awl); + if (SCHEME_VECTORP(p)) { + skipable++; + } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { + /* ok to skip, but don<'t count toward needing a cache */ + } else if (SCHEME_HASHTP(p)) { + /* Hack: we store the depth of the table in the chain + in the `size' fields, at least until the table is initialized: */ + Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p; + if (!ht2->count) + pos = ht2->size; + else { + p = scheme_hash_get(ht2, scheme_make_integer(2)); + pos = SCHEME_INT_VAL(p); + } + pos++; + break; + } else + break; + WRAP_POS_INC(awl); + } + + if (skipable >= 32) { + /* Insert a cache placeholder. We'll fill it if + it's ever used in resolve_env(). */ + Scheme_Hash_Table *ht; + + ht = scheme_make_hash_table(SCHEME_hash_ptr); + + ht->size = pos; + + p = scheme_make_pair((Scheme_Object *)ht, stx->wraps); + stx->wraps = p; + + if (STX_KEY(stx) & STX_SUBSTX_FLAG) + stx->u.lazy_prefix++; + + return 1; + } + + return 0; +} + +static void set_wraps_to_skip(Scheme_Hash_Table *ht, WRAP_POS *wraps) +{ + Scheme_Object *v; + + v = scheme_hash_get(ht, scheme_make_integer(0)); + wraps->l = v; + v = scheme_hash_get(ht, scheme_make_integer(1)); + if (SCHEME_TRUEP(v)) { + wraps->pos = SCHEME_INT_VAL(v); + wraps->is_limb = 1; + wraps->a = ((Wrap_Chunk *)SCHEME_CAR(wraps->l))->a[wraps->pos]; + } else { + wraps->is_limb = 0; + if (!SCHEME_NULLP(wraps->l)) + wraps->a = SCHEME_CAR(wraps->l); + } +} + +static void fill_chain_cache(Scheme_Object *wraps) +{ + int pos, max_depth, limit; + Scheme_Hash_Table *ht; + Scheme_Object *p, *id; + WRAP_POS awl; + + ht = (Scheme_Hash_Table *)SCHEME_CAR(wraps); + + p = scheme_hash_get(ht, scheme_make_integer(5)); + if (p) { + limit = SCHEME_INT_VAL(p); + + /* Extend the chain cache to deeper: */ + set_wraps_to_skip(ht, &awl); + + p = scheme_hash_get(ht, scheme_make_integer(2)); + pos = SCHEME_INT_VAL(p); + + scheme_hash_set(ht, scheme_make_integer(5), NULL); + } else { + pos = ht->size; + ht->size = 0; + + wraps = SCHEME_CDR(wraps); + + WRAP_POS_INIT(awl, wraps); + + limit = 4; + } + + /* Limit how much of the cache we build, in case we never + reuse this cache: */ + max_depth = limit; + + while (!WRAP_POS_END_P(awl)) { + if (!(max_depth--)) { + limit *= 2; + scheme_hash_set(ht, scheme_make_integer(5), scheme_make_integer(limit)); + break; + } + + p = WRAP_POS_FIRST(awl); + if (SCHEME_VECTORP(p)) { + int i, len; + len = SCHEME_RENAME_LEN(p); + for (i = 0; i < len; i++) { + id = SCHEME_VEC_ELS(p)[i+2]; + if (SCHEME_STXP(id)) + id = SCHEME_STX_VAL(id); + scheme_hash_set(ht, id, scheme_true); + } + } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { + /* ok to skip */ + } else if (SCHEME_HASHTP(p)) { + /* Hack: we store the depth of the table in the chain + in the `size' fields, at least until the table is initialized: */ + Scheme_Hash_Table *ht2 = (Scheme_Hash_Table *)p; + int pos2; + if (!ht2->count) + pos2 = ht2->size; + else { + p = scheme_hash_get(ht2, scheme_make_integer(2)); + pos2 = SCHEME_INT_VAL(p); + } + /* The theory here is the same as the `mapped' table: + every power of two covers the whole range, etc. */ + if ((pos & pos2) == pos2) + break; + } else + break; + WRAP_POS_INC(awl); + } + + /* Record skip destination: */ + scheme_hash_set(ht, scheme_make_integer(0), awl.l); + if (!awl.is_limb) { + scheme_hash_set(ht, scheme_make_integer(1), scheme_false); + } else { + scheme_hash_set(ht, scheme_make_integer(1), scheme_make_integer(awl.pos)); + } + scheme_hash_set(ht, scheme_make_integer(2), scheme_make_integer(pos)); +} + +/******************** marks ********************/ + +Scheme_Object *scheme_new_mark() +{ + mark_id = scheme_add1(1, &mark_id); + return mark_id; +} + +static Scheme_Object *negate_mark(Scheme_Object *n) +{ + return scheme_bin_minus(scheme_make_integer(0), n); +} + +Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m) +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + Scheme_Object *wraps; + Scheme_Object *certs; + intptr_t lp; + + if (STX_KEY(stx) & STX_SUBSTX_FLAG) + lp = stx->u.lazy_prefix; + else + lp = 1; + + wraps = stx->wraps; + if (SCHEME_PAIRP(wraps) + && SAME_OBJ(m, SCHEME_CAR(wraps)) + && lp) { + --lp; + wraps = SCHEME_CDR(wraps); + } else { + if (maybe_add_chain_cache(stx)) + lp++; + wraps = stx->wraps; + lp++; + wraps = CONS(m, wraps); + } + + certs = stx->certs; + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); + stx->wraps = wraps; + stx->certs = certs; + + if (STX_KEY(stx) & STX_SUBSTX_FLAG) + stx->u.lazy_prefix = lp; + /* else cache should stay zeroed */ + + return (Scheme_Object *)stx; +} + +/******************** lexical renames ********************/ + +#define RENAME_HT_THRESHOLD 15 + +Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) +{ + Scheme_Object *v; + int i; + + v = scheme_make_vector((2 * c) + 2, NULL); + SCHEME_VEC_ELS(v)[0] = newname; + if (c > RENAME_HT_THRESHOLD) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; + } else + SCHEME_VEC_ELS(v)[1] = scheme_false; + + for (i = 0; i < c; i++) { + SCHEME_VEC_ELS(v)[2 + c + i] = scheme_void; + } + + return v; +} + +static void maybe_install_rename_hash_table(Scheme_Object *v) +{ + if (SCHEME_VEC_SIZE(v) > ((2 * RENAME_HT_THRESHOLD) + 2)) { + Scheme_Hash_Table *ht; + int i; + + ht = scheme_make_hash_table(SCHEME_hash_ptr); + MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; + for (i = (SCHEME_VEC_SIZE(v) - 2) >> 1; i--; ) { + scheme_hash_set(ht, SCHEME_VEC_ELS(v)[i + 2], scheme_make_integer(i)); + } + SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; + } +} + +void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname) +{ + /* Every added name must be symbolicly distinct! */ + + SCHEME_VEC_ELS(rnm)[2 + pos] = oldname; + + /* Add ht mapping, if there's a hash table: */ + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rnm)[1])) { + Scheme_Hash_Table *ht; + ht = (Scheme_Hash_Table *)SCHEME_VEC_ELS(rnm)[1]; + if (scheme_hash_get(ht, SCHEME_STX_VAL(oldname))) + pos = -1; /* -1 means multiple entries matching a name */ + scheme_hash_set(ht, SCHEME_STX_VAL(oldname), scheme_make_integer(pos)); + } +} + +Scheme_Object *scheme_make_rename_rib() +{ + Scheme_Lexical_Rib *rib; + int *sealed; + + rib = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); + rib->so.type = scheme_lexical_rib_type; + rib->timestamp = current_rib_timestamp; + + sealed = (int *)scheme_malloc_atomic(sizeof(int)); + *sealed = 0; + rib->sealed = sealed; + + current_rib_timestamp = scheme_add1(1, ¤t_rib_timestamp); + + return (Scheme_Object *)rib; +} + +void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) +{ + Scheme_Lexical_Rib *rib, *naya; + Scheme_Object *next; + Scheme_Hash_Table *mapped_names; + int i; + + naya = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); + naya->so.type = scheme_lexical_rib_type; + naya->rename = rename; + + rib = (Scheme_Lexical_Rib *)ro; + naya->next = rib->next; + rib->next = naya; + + naya->timestamp = rib->timestamp; + naya->sealed = rib->sealed; + + while (unsealed_dependencies) { + next = SCHEME_CDR(unsealed_dependencies); + SCHEME_CAR(unsealed_dependencies) = NULL; + SCHEME_CDR(unsealed_dependencies) = NULL; + unsealed_dependencies = next; + } + + if (!rib->mapped_names) + rib->mapped_names = scheme_make_integer(1); + else if (SCHEME_INTP(rib->mapped_names)) { + rib->mapped_names = scheme_make_integer(SCHEME_INT_VAL(rib->mapped_names) + 1); + if (SCHEME_INT_VAL(rib->mapped_names) > 32) { + /* Build the initial table */ + mapped_names = scheme_make_hash_table(SCHEME_hash_ptr); + while (naya) { + for (i = SCHEME_RENAME_LEN(naya->rename); i--; ) { + scheme_hash_set(mapped_names, + SCHEME_STX_SYM(SCHEME_VEC_ELS(naya->rename)[2+i]), + scheme_true); + } + naya = naya->next; + } + rib->mapped_names = (Scheme_Object *)mapped_names; + } + } else { + for (i = SCHEME_RENAME_LEN(naya->rename); i--; ) { + scheme_hash_set((Scheme_Hash_Table *)rib->mapped_names, + SCHEME_STX_SYM(SCHEME_VEC_ELS(naya->rename)[2+i]), + scheme_true); + } + } +} + +void scheme_drop_first_rib_rename(Scheme_Object *ro) +{ + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro; + rib->next = rib->next->next; +} + +void scheme_stx_seal_rib(Scheme_Object *rib) +{ + *((Scheme_Lexical_Rib *)rib)->sealed = 1; +} + +int *scheme_stx_get_rib_sealed(Scheme_Object *rib) +{ + return ((Scheme_Lexical_Rib *)rib)->sealed; +} + +Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro) +{ + Scheme_Object *v; + int count = 0, rib_count = 0; + WRAP_POS awl; + Wrap_Chunk *wc; + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)ro, *rib2; + + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(awl)) { + count++; + v = WRAP_POS_FIRST(awl); + if (SCHEME_RIBP(v)) { + rib2 = (Scheme_Lexical_Rib *)v; + if (SAME_OBJ(rib2->timestamp, rib->timestamp)) + rib_count++; + } + WRAP_POS_INC(awl); + } + + if (!rib_count) + return stx; + + count -= rib_count; + + wc = MALLOC_WRAP_CHUNK(count); + wc->type = scheme_wrap_chunk_type; + wc->len = count; + + count = 0; + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(awl)) { + v = WRAP_POS_FIRST(awl); + if (SCHEME_RIBP(v)) { + rib2 = (Scheme_Lexical_Rib *)v; + if (SAME_OBJ(rib2->timestamp, rib->timestamp)) + v = NULL; + } + if (v) { + wc->a[count++] = v; + } + WRAP_POS_INC(awl); + } + + v = scheme_make_pair((Scheme_Object *)wc, scheme_null); + + stx = scheme_add_rename(stx, scheme_make_integer(0)); + ((Scheme_Stx *)stx)->wraps = v; - if (defmacro > 1) - scheme_pop_prefix(save_runstack); + return stx; +} - { - const char *symname; +static Scheme_Object *make_prune_context(Scheme_Object *a) +{ + Scheme_Object *p; - symname = (show_any ? scheme_symbol_name(name) : ""); + p = scheme_alloc_small_object(); + p->type = scheme_prune_context_type; + SCHEME_BOX_VAL(p) = a; - scheme_wrong_return_arity((defmacro - ? (dm_env ? "define-syntaxes" : "define-values-for-syntax") - : "define-values"), - i, g, - (g == 1) ? (Scheme_Object **)vals : scheme_current_thread->ku.multiple.array, - "%s%s%s", - show_any ? "defining \"" : "0 names", - symname, - show_any ? ((i == 1) ? "\"" : "\", ...") : ""); + return p; +} + +/******************** module renames ********************/ + +static int same_phase(Scheme_Object *a, Scheme_Object *b) +{ + if (SAME_OBJ(a, b)) + return 1; + else if (SCHEME_INTP(a) || SCHEME_INTP(b) + || SCHEME_FALSEP(a) || SCHEME_FALSEP(b)) + return 0; + else + return scheme_eqv(a, b); +} + +Scheme_Object *scheme_make_module_rename_set(int kind, Scheme_Object *share_marked_names) +{ + Module_Renames_Set *mrns; + Scheme_Object *mk; + + if (share_marked_names) + mk = ((Module_Renames_Set *)share_marked_names)->set_identity; + else + mk = scheme_new_mark(); + + mrns = MALLOC_ONE_TAGGED(Module_Renames_Set); + mrns->so.type = scheme_rename_table_set_type; + mrns->kind = kind; + mrns->share_marked_names = share_marked_names; + mrns->set_identity = mk; + + return (Scheme_Object *)mrns; +} + +void scheme_add_module_rename_to_set(Scheme_Object *set, Scheme_Object *rn) +{ + Module_Renames_Set *mrns = (Module_Renames_Set *)set; + Module_Renames *mrn = (Module_Renames *)rn; + + mrn->set_identity = mrns->set_identity; + + if (same_phase(mrn->phase, scheme_make_integer(0))) + mrns->rt = mrn; + else if (same_phase(mrn->phase, scheme_make_integer(1))) + mrns->et = mrn; + else { + Scheme_Hash_Table *ht; + ht = mrns->other_phases; + if (!ht) { + ht = scheme_make_hash_table_equal(); + mrns->other_phases = ht; + } + scheme_hash_set(ht, mrn->phase, (Scheme_Object *)mrn); + } +} + +Scheme_Object *scheme_get_module_rename_from_set(Scheme_Object *set, Scheme_Object *phase, int create) +{ + Module_Renames_Set *mrns = (Module_Renames_Set *)set; + Module_Renames *mrn; + + if (same_phase(phase, scheme_make_integer(0))) + mrn = mrns->rt; + else if (same_phase(phase, scheme_make_integer(1))) + mrn = mrns->et; + else if (mrns->other_phases) + mrn = (Module_Renames *)scheme_hash_get(mrns->other_phases, phase); + else + mrn = NULL; + + if (!mrn && create) { + Scheme_Hash_Table *marked_names; + + if (mrns->share_marked_names) + marked_names = scheme_get_module_rename_marked_names(mrns->share_marked_names, phase, 1); + else + marked_names = NULL; + + mrn = (Module_Renames *)scheme_make_module_rename(phase, mrns->kind, marked_names); + + scheme_add_module_rename_to_set(set, (Scheme_Object *)mrn); + } + + return (Scheme_Object *)mrn; +} + +Scheme_Hash_Table *scheme_get_module_rename_marked_names(Scheme_Object *set, Scheme_Object *phase, int create) +{ + Scheme_Object *rn; + + rn = scheme_get_module_rename_from_set(set, phase, create); + if (!rn) + return NULL; + + if (((Module_Renames *)rn)->marked_names) + return ((Module_Renames *)rn)->marked_names; + + if (create) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + ((Module_Renames *)rn)->marked_names = ht; + return ht; } return NULL; } -Scheme_Object * -scheme_define_values_execute(Scheme_Object *data) +Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *marked_names) { - return define_execute_with_dynamic_state(data, 1, 0, NULL, NULL, NULL); + Module_Renames *mr; + Scheme_Hash_Table *ht; + Scheme_Object *mk; + + mk = scheme_new_mark(); + + mr = MALLOC_ONE_TAGGED(Module_Renames); + mr->so.type = scheme_rename_table_type; + + ht = scheme_make_hash_table(SCHEME_hash_ptr); + + mr->ht = ht; + mr->phase = phase; + mr->kind = kind; + mr->set_identity = mk; + mr->marked_names = marked_names; + mr->shared_pes = scheme_null; + mr->unmarshal_info = scheme_null; + + return (Scheme_Object *)mr; } -static Scheme_Object *clone_vector(Scheme_Object *data, int skip, int set_type) +void scheme_seal_module_rename(Scheme_Object *rn, int level) { - Scheme_Object *naya; - int i, size; - - size = SCHEME_VEC_SIZE(data); - naya = scheme_make_vector(size - skip, NULL); - for (i = skip; i < size; i++) { - SCHEME_VEC_ELS(naya)[i - skip] = SCHEME_VEC_ELS(data)[i]; - } - - if (set_type) - naya->type = data->type; - - return naya; + ((Module_Renames *)rn)->sealed = level; } -Scheme_Object *scheme_define_values_jit(Scheme_Object *data) +void scheme_seal_module_rename_set(Scheme_Object *_rns, int level) { - Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya; - - if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type) - && (SCHEME_VEC_SIZE(data) == 2)) - naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]); - else - naya = scheme_jit_expr(orig); - - if (SAME_OBJ(naya, orig)) - return data; - else { - orig = naya; - naya = clone_vector(data, 0, 1); - SCHEME_VEC_ELS(naya)[0] = orig; - return naya; - } -} - -void scheme_define_values_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - int i, size; - Scheme_Object *val, *only_var; - - val = SCHEME_VEC_ELS(data)[0]; - size = SCHEME_VEC_SIZE(data); - - if (size == 2) - only_var = SCHEME_VEC_ELS(data)[1]; - else - only_var = NULL; - - for (i = 1; i < size; i++) { - scheme_validate_toplevel(SCHEME_VEC_ELS(data)[i], port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - 1); - } - - if (only_var) { - int pos; - pos = SCHEME_TOPLEVEL_POS(only_var); - if (pos >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { - /* It's a lift. Check whether it needs to take reference arguments - and/or install reference info. */ - Scheme_Object *app_rator; - Scheme_Closure_Data *data = NULL; - int tp = pos - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); - mzshort *a, *new_a = NULL; - - /* Make sure that no one has tried to register information. */ - a = tls[tp]; - if (a && (a != (mzshort *)0x1) && (a[0] < 1)) - scheme_ill_formed_code(port); - - /* Convert rator to ref-arg info: */ - app_rator = val; - while (1) { - if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_closure_type)) { - data = SCHEME_COMPILED_CLOS_CODE(app_rator); - break; - } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_unclosed_procedure_type)) { - data = (Scheme_Closure_Data *)app_rator; - break; - } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_toplevel_type)) { - /* Record an indirection */ - data = NULL; - new_a = MALLOC_N_ATOMIC(mzshort, 2); - new_a[0] = 0; - new_a[1] = SCHEME_TOPLEVEL_POS(app_rator); - break; - } else { - /* Not a procedure */ - data = NULL; - new_a = (mzshort *)0x1; - break; - } - } - if (data) { - if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { - int sz; - sz = data->num_params; - a = MALLOC_N_ATOMIC(mzshort, (sz + 1)); - a[0] = -sz; - for (i = 0; i < sz; i++) { - int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); - if (data->closure_map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) - a[i + 1] = 1; - else - a[i + 1] = 0; - } - } else { - new_a = (mzshort *)0x1; - } - } - - /* Install info: */ - tls[tp] = new_a; - - /* Check old hopes against actual */ - if (a == (mzshort *)0x1) { - if (new_a != (mzshort *)0x1) - scheme_ill_formed_code(port); - } else if (a) { - int cnt = a[0], i; - - for (i = 0; i < cnt; i++) { - if (a[i + 1]) { - int is; - is = scheme_validate_rator_wants_box(val, i, - a[i + 1] == 2, - tls, num_toplevels, num_stxes, num_lifts, tl_use_map); - if ((is && (a[i + 1] == 1)) - || (!is && (a[i + 1] == 2))) - scheme_ill_formed_code(port); - } - } - } - } else - only_var = NULL; - } - - scheme_validate_expr(port, val, stack, tls, - depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, !!only_var, 0, vc, 0, 0, NULL); -} - -Scheme_Object * -scheme_define_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - Scheme_Object *vars = SCHEME_VEC_ELS(data)[0]; - Scheme_Object *val = SCHEME_VEC_ELS(data)[1]; - - scheme_optimize_info_used_top(info); - val = scheme_optimize_expr(val, info, 0); - - SCHEME_VEC_ELS(data)[0] = vars; - SCHEME_VEC_ELS(data)[1] = val; - - return data; -} - -Scheme_Object * -scheme_define_values_resolve(Scheme_Object *data, Resolve_Info *rslv) -{ - intptr_t cnt = 0; - Scheme_Object *vars = SCHEME_VEC_ELS(data)[0], *l, *a; - Scheme_Object *val = SCHEME_VEC_ELS(data)[1], *vec; - - /* If this is a module-level definition: for each variable, if the - defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then - resolve to a top-level reference with SCHEME_TOPLEVEL_CONST, so - that we know to set GLOS_IS_IMMUTATED at run time. */ - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - if (rslv->in_module - && rslv->enforce_const - && (!(SCHEME_TOPLEVEL_FLAGS(a) & SCHEME_TOPLEVEL_MUTATED))) { - a = scheme_toplevel_to_flagged_toplevel(a, SCHEME_TOPLEVEL_CONST); - } - a = scheme_resolve_toplevel(rslv, a, 0); - SCHEME_CAR(l) = a; - cnt++; - } - - vec = scheme_make_vector(cnt + 1, NULL); - cnt = 1; - for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - SCHEME_VEC_ELS(vec)[cnt++] = SCHEME_CAR(l); - } - - val = scheme_resolve_expr(val, rslv); - SCHEME_VEC_ELS(vec)[0] = val; - - vec->type = scheme_define_values_type; - return vec; -} - -Scheme_Object * -scheme_define_values_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *e; - scheme_sfs_start_sequence(info, 1, 0); - e = scheme_sfs_expr(SCHEME_VEC_ELS(data)[0], info, -1); - SCHEME_VEC_ELS(data)[0] = e; - return data; -} - -void scheme_resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs) -{ - Scheme_Object *decl, *vec, *pr; - - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = rhs; - SCHEME_VEC_ELS(vec)[1] = var; - - vec->type = scheme_define_values_type; - - decl = vec; - - vec = info->lifts; - pr = cons(decl, SCHEME_VEC_ELS(vec)[0]); - SCHEME_VEC_ELS(vec)[0] = pr; -} - -void scheme_define_parse(Scheme_Object *form, - Scheme_Object **var, Scheme_Object **_stk_val, - int defmacro, - Scheme_Comp_Env *env, - int no_toplevel_check) -{ - Scheme_Object *vars, *rest; - int len; - DupCheckRecord r; - - if (!no_toplevel_check && !scheme_is_toplevel(env)) - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); - - len = check_form(form, form); - if (len != 3) - bad_form(form, len); + Module_Renames_Set *rns = (Module_Renames_Set *)_rns; - rest = SCHEME_STX_CDR(form); - vars = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - *_stk_val = SCHEME_STX_CAR(rest); + rns->sealed = level; + if (rns->rt) + rns->rt->sealed = level; + if (rns->et) + rns->et->sealed = level; + if (rns->other_phases) { + int i; + for (i = 0; i < rns->other_phases->size; i++) { + if (rns->other_phases->vals[i]) { + ((Module_Renames *)rns->other_phases->vals[i])->sealed = level; + } + } + } +} - *var = vars; +static void check_not_sealed(Module_Renames *mrn) +{ + if (mrn->sealed >= STX_SEAL_ALL) + scheme_signal_error("internal error: attempt to change sealed module rename"); +} - scheme_begin_dup_symbol_check(&r, env); +static Scheme_Object *phase_to_index(Scheme_Object *phase) +{ + return phase; +} - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *name; +Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, + Scheme_Object *modname, /* actual source module */ + Scheme_Object *localname, /* name in local context */ + Scheme_Object *exname, /* name in definition context */ + Scheme_Object *nominal_mod, /* nominal source module */ + Scheme_Object *nominal_ex, /* nominal import before local renaming */ + intptr_t mod_phase, /* phase of source defn */ + Scheme_Object *src_phase_index, /* nominal import phase */ + Scheme_Object *nom_phase, /* nominal export phase */ + Scheme_Object *insp, /* inspector for re-export */ + int mode) /* 1 => can be reconstructed from unmarshal info + 2 => free-id=? renaming + 3 => return info */ +{ + Scheme_Object *elem; + Scheme_Object *phase_index; - name = SCHEME_STX_CAR(vars); - scheme_check_identifier(NULL, name, NULL, env, form); + if (mode != 3) + check_not_sealed((Module_Renames *)mrn); - vars = SCHEME_STX_CDR(vars); + phase_index = phase_to_index(((Module_Renames *)mrn)->phase); + if (!src_phase_index) + src_phase_index = phase_index; + if (!nom_phase) + nom_phase = scheme_make_integer(mod_phase); - scheme_dup_symbol_check(&r, NULL, name, "binding", form); + if (SAME_OBJ(modname, nominal_mod) + && SAME_OBJ(exname, nominal_ex) + && !mod_phase + && same_phase(src_phase_index, phase_index) + && same_phase(nom_phase, scheme_make_integer(mod_phase))) { + if (SAME_OBJ(localname, exname)) + elem = modname; + else + elem = CONS(modname, exname); + } else if (SAME_OBJ(exname, nominal_ex) + && SAME_OBJ(localname, exname) + && !mod_phase + && same_phase(src_phase_index, phase_index) + && same_phase(nom_phase, scheme_make_integer(mod_phase))) { + /* It's common that a sequence of similar mappings shows up, + e.g., '(#%kernel . mzscheme) */ + if (nominal_ipair_cache + && SAME_OBJ(SCHEME_CAR(nominal_ipair_cache), modname) + && SAME_OBJ(SCHEME_CDR(nominal_ipair_cache), nominal_mod)) + elem = nominal_ipair_cache; + else { + elem = ICONS(modname, nominal_mod); + nominal_ipair_cache = elem; + } + } else { + if (same_phase(nom_phase, scheme_make_integer(mod_phase))) { + if (same_phase(src_phase_index, phase_index)) + elem = nominal_mod; + else + elem = CONS(nominal_mod, src_phase_index); + } else { + elem = CONS(nominal_mod, CONS(src_phase_index, nom_phase)); + } + elem = CONS(exname, CONS(elem, nominal_ex)); + if (mod_phase) + elem = CONS(scheme_make_integer(mod_phase), elem); + elem = CONS(modname, elem); + } + + if (insp) + elem = CONS(insp, elem); + + if (mode == 1) { + if (!((Module_Renames *)mrn)->nomarshal_ht) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + ((Module_Renames *)mrn)->nomarshal_ht = ht; + } + scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, elem); + } else if (mode == 2) { + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, elem); + } else if (mode == 3) { + return elem; + } else + scheme_hash_set(((Module_Renames *)mrn)->ht, localname, elem); + + return NULL; +} + +void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, + Scheme_Module_Phase_Exports *pt, + Scheme_Object *unmarshal_phase_index, + Scheme_Object *src_phase_index, + Scheme_Object *marks, + int save_unmarshal) +{ + Module_Renames *mrn = (Module_Renames *)rn; + Scheme_Object *pr, *index_plus_marks; + + check_not_sealed(mrn); + + if (SCHEME_PAIRP(marks)) + index_plus_marks = scheme_make_pair(marks, src_phase_index); + else + index_plus_marks = src_phase_index; + + pr = scheme_make_pair(scheme_make_pair(modidx, + scheme_make_pair((Scheme_Object *)pt, + index_plus_marks)), + mrn->shared_pes); + mrn->shared_pes = pr; + + if (save_unmarshal) { + pr = scheme_make_pair(scheme_make_pair(modidx, + scheme_make_pair(unmarshal_phase_index, + index_plus_marks)), + mrn->unmarshal_info); + mrn->unmarshal_info = pr; + } +} + +void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info) +{ + Scheme_Object *l; + + l = scheme_make_pair(info, ((Module_Renames *)rn)->unmarshal_info); + ((Module_Renames *)rn)->unmarshal_info = l; +} + +static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, + Scheme_Object *old_midx, Scheme_Object *new_midx, + int do_pes, int do_unm, + Scheme_Object *new_insp) +{ + Scheme_Hash_Table *ht, *hts, *drop_ht; + Scheme_Object *v; + int i, t; + + check_not_sealed((Module_Renames *)dest); + + if (do_pes) { + if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) { + Scheme_Object *first = NULL, *last = NULL, *pr, *l; + for (l = ((Module_Renames *)src)->shared_pes; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + pr = scheme_make_pair(SCHEME_CAR(l), scheme_null); + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + } + SCHEME_CDR(last) = ((Module_Renames *)dest)->shared_pes; + ((Module_Renames *)dest)->shared_pes = first; + } + } + + if (do_unm) { + if (!SCHEME_NULLP(((Module_Renames *)src)->unmarshal_info)) { + Scheme_Object *first = NULL, *last = NULL, *pr, *l; + for (l = ((Module_Renames *)src)->unmarshal_info; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { + pr = scheme_make_pair(SCHEME_CAR(l), scheme_null); + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + } + SCHEME_CDR(last) = ((Module_Renames *)dest)->unmarshal_info; + ((Module_Renames *)dest)->unmarshal_info = first; + + ((Module_Renames *)dest)->needs_unmarshal = 1; + } + } + + for (t = 0; t < 2; t++) { + if (!t) { + ht = ((Module_Renames *)dest)->ht; + hts = ((Module_Renames *)src)->ht; + drop_ht = ((Module_Renames *)dest)->nomarshal_ht; + } else { + hts = ((Module_Renames *)src)->nomarshal_ht; + if (!hts) + break; + ht = ((Module_Renames *)dest)->nomarshal_ht; + if (!ht) { + ht = scheme_make_hash_table(SCHEME_hash_ptr); + ((Module_Renames *)dest)->nomarshal_ht = ht; + } + drop_ht = ((Module_Renames *)dest)->ht; + } + + /* Mappings in src overwrite mappings in dest: */ + + for (i = hts->size; i--; ) { + if (hts->vals[i]) { + v = hts->vals[i]; + if (old_midx) { + Scheme_Object *insp = NULL; + + if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) { + insp = SCHEME_CAR(v); + if (new_insp) insp = new_insp; + v = SCHEME_CDR(v); + } else + insp = NULL; + + /* Shift the modidx part */ + if (SCHEME_PAIRP(v)) { + if (SCHEME_PAIRP(SCHEME_CDR(v))) { + /* (list* modidx [mod-phase] exportname nominal_modidx+index nominal_exportname) */ + Scheme_Object *midx1, *midx2; + intptr_t mod_phase; + midx1 = SCHEME_CAR(v); + v = SCHEME_CDR(v); + if (SCHEME_INTP(SCHEME_CAR(v))) { + mod_phase = SCHEME_INT_VAL(SCHEME_CAR(v)); + v = SCHEME_CDR(v); + } else + mod_phase = 0; + midx2 = SCHEME_CAR(SCHEME_CDR(v)); + midx1 = scheme_modidx_shift(midx1, old_midx, new_midx); + if (SCHEME_PAIRP(midx2)) { + midx2 = scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(midx2), old_midx, new_midx), + SCHEME_CDR(midx2)); + } else { + midx2 = scheme_modidx_shift(midx2, old_midx, new_midx); + } + v = CONS(SCHEME_CAR(v), CONS(midx2, SCHEME_CDR(SCHEME_CDR(v)))); + if (mod_phase) + v = CONS(scheme_make_integer(mod_phase), v); + v = CONS(midx1, v); + } else if (nom_mod_p(v)) { + /* (cons modidx nominal_modidx) */ + v = ICONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx), + scheme_modidx_shift(SCHEME_CDR(v), old_midx, new_midx)); + } else { + /* (cons modidx exportname) */ + v = CONS(scheme_modidx_shift(SCHEME_CAR(v), old_midx, new_midx), + SCHEME_CDR(v)); + } + } else { + /* modidx */ + v = scheme_modidx_shift(v, old_midx, new_midx); + } + + if (insp) + v = CONS(insp, v); + } + scheme_hash_set(ht, hts->keys[i], v); + if (drop_ht) + scheme_hash_set(drop_ht, hts->keys[i], NULL); + } + } + } + + /* Need to share marked names: */ + + if (((Module_Renames *)src)->marked_names) { + ((Module_Renames *)dest)->marked_names = ((Module_Renames *)src)->marked_names; + } +} + +void scheme_append_module_rename(Scheme_Object *src, Scheme_Object *dest, int do_unm) +{ + do_append_module_rename(src, dest, NULL, NULL, 1, do_unm, NULL); +} + +void scheme_append_rename_set_to_env(Scheme_Object *_mrns, Scheme_Env *env) +{ + Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns; + Scheme_Object *mrns2; + int i; + + scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); + mrns2 = env->rename_set; + + if (mrns->rt) { + scheme_append_module_rename((Scheme_Object *)mrns->rt, + scheme_get_module_rename_from_set(mrns2, scheme_make_integer(0), 1), + 1); + } + if (mrns->et) { + scheme_append_module_rename((Scheme_Object *)mrns->et, + scheme_get_module_rename_from_set(mrns2, scheme_make_integer(1), 1), + 1); + } + if (mrns->other_phases) { + for (i = 0; i < mrns->other_phases->size; i++) { + if (mrns->other_phases->vals[i]) { + scheme_append_module_rename(mrns->other_phases->vals[i], + scheme_get_module_rename_from_set(mrns2, + mrns->other_phases->keys[i], + 1), + 1); + } + } + } +} + +void scheme_remove_module_rename(Scheme_Object *mrn, + Scheme_Object *localname) +{ + check_not_sealed((Module_Renames *)mrn); + scheme_hash_set(((Module_Renames *)mrn)->ht, localname, NULL); + if (((Module_Renames *)mrn)->nomarshal_ht) + scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, NULL); + if (((Module_Renames *)mrn)->free_id_renames) + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, NULL); +} + +void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht, + Scheme_Hash_Table *export_registry) +{ + /* Put every name mapped by src into ht: */ + Scheme_Object *pr; + Scheme_Hash_Table *hts; + int i, t; + Scheme_Module_Phase_Exports *pt; + Module_Renames *src; + + if (SCHEME_RENAMES_SETP(set)) + src = ((Module_Renames_Set *)set)->rt; + else + src = (Module_Renames *)set; + + if (!src) + return; + + if (src->needs_unmarshal) { + unmarshal_rename(src, NULL, NULL, export_registry); + } + + for (t = 0; t < 2; t++) { + if (!t) + hts = src->ht; + else { + hts = src->nomarshal_ht; + } + + if (hts) { + for (i = hts->size; i--; ) { + if (hts->vals[i]) { + scheme_hash_set(ht, hts->keys[i], scheme_false); + } + } + } + } + + for (pr = src->shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { + pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); + for (i = pt->num_provides; i--; ) { + scheme_hash_set(ht, pt->provides[i], scheme_false); + } + } +} + + +Scheme_Object *scheme_rename_to_stx(Scheme_Object *mrn) +{ + Scheme_Object *stx; + stx = scheme_make_stx(scheme_false, empty_srcloc, NULL); + return scheme_add_rename(stx, mrn); +} + +Scheme_Object *scheme_stx_to_rename(Scheme_Object *stx) +{ + Scheme_Object *rns = NULL, *v; + WRAP_POS wl; + + WRAP_POS_INIT(wl, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(wl)) { + v = WRAP_POS_FIRST(wl); + if (SCHEME_RENAMES_SETP(v)) { + if (rns) + scheme_signal_error("can't convert syntax to rename (two sets)"); + rns = v; + } else if (SCHEME_RENAMESP(v)) { + if (!rns) + rns = scheme_make_module_rename_set(((Module_Renames *)v)->kind, NULL); + scheme_add_module_rename_to_set(rns, v); + } else { + scheme_signal_error("can't convert syntax to rename (non-rename in wrap)"); + } + WRAP_POS_INC(wl); + } + + if (!rns) + scheme_signal_error("can't convert syntax to rename (empty)"); + + return rns; +} + +Scheme_Object *scheme_stx_shift_rename(Scheme_Object *mrn, + Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Object *new_insp) +{ + Scheme_Object *nmrn, *a, *l, *nl, *first, *last; + + nmrn = scheme_make_module_rename(((Module_Renames *)mrn)->phase, + mzMOD_RENAME_NORMAL, + NULL); + + /* use "append" to copy most info: */ + do_append_module_rename(mrn, nmrn, old_midx, new_midx, 0, 0, new_insp); + + /* Manually copy unmarshal_infos, where we have to shift anyway: */ + + l = ((Module_Renames *)mrn)->unmarshal_info; + first = scheme_null; + last = NULL; + while (!SCHEME_NULLP(l)) { + a = SCHEME_CAR(l); + nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx), + SCHEME_CDR(a)), + scheme_null); + if (last) + SCHEME_CDR(last) = nl; + else + first = nl; + last = nl; + l = SCHEME_CDR(l); + } + ((Module_Renames *)nmrn)->unmarshal_info = first; + + l = ((Module_Renames *)mrn)->shared_pes; + first = scheme_null; + last = NULL; + while (!SCHEME_NULLP(l)) { + a = SCHEME_CAR(l); + nl = scheme_make_pair(scheme_make_pair(scheme_modidx_shift(SCHEME_CAR(a), old_midx, new_midx), + SCHEME_CDR(a)), + scheme_null); + if (last) + SCHEME_CDR(last) = nl; + else + first = nl; + last = nl; + l = SCHEME_CDR(l); + } + ((Module_Renames *)nmrn)->shared_pes = first; + + if (((Module_Renames *)mrn)->needs_unmarshal) { + ((Module_Renames *)nmrn)->needs_unmarshal = 1; } - if (!SCHEME_STX_NULLP(vars)) - scheme_wrong_syntax(NULL, *var, form, "bad variable list"); + return nmrn; } -static Scheme_Object * -defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +Scheme_Object *scheme_stx_shift_rename_set(Scheme_Object *_mrns, + Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Object *new_insp) { - Scheme_Object *first = scheme_null, *last = NULL; + Module_Renames_Set *mrns = (Module_Renames_Set *)_mrns; + Scheme_Object *mrn, *mrns2; + int i; - while (SCHEME_STX_PAIRP(var)) { - Scheme_Object *name, *pr, *bucket; - - name = SCHEME_STX_CAR(var); - name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); - - if (rec[drec].resolve_module_ids || !env->genv->module) { - bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); - } else { - /* Create a module variable reference, so that idx is preserved: */ - bucket = scheme_hash_module_variable(env->genv, env->genv->module->self_modidx, - name, env->genv->module->insp, - -1, env->genv->mod_phase); + mrns2 = scheme_make_module_rename_set(mrns->kind, NULL); + if (mrns->rt) { + mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->rt, old_midx, new_midx, new_insp); + scheme_add_module_rename_to_set(mrns2, mrn); + } + if (mrns->et) { + mrn = scheme_stx_shift_rename((Scheme_Object *)mrns->et, old_midx, new_midx, new_insp); + scheme_add_module_rename_to_set(mrns2, mrn); + } + if (mrns->other_phases) { + for (i = 0; i < mrns->other_phases->size; i++) { + if (mrns->other_phases->vals[i]) { + mrn = scheme_stx_shift_rename(mrns->other_phases->vals[i], old_midx, new_midx, new_insp); + scheme_add_module_rename_to_set(mrns2, mrn); + } } - /* Get indirection through the prefix: */ - bucket = scheme_register_toplevel_in_prefix(bucket, env, rec, drec, 0); + } - pr = cons(bucket, scheme_null); + return (Scheme_Object *)mrns2; +} + + +Scheme_Hash_Table *scheme_module_rename_marked_names(Scheme_Object *rn) +{ + return ((Module_Renames *)rn)->marked_names; +} + +static void unmarshal_rename(Module_Renames *mrn, + Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, + Scheme_Hash_Table *export_registry) +{ + Scheme_Object *l; + int sealed; + + mrn->needs_unmarshal = 0; + + sealed = mrn->sealed; + if (sealed) + mrn->sealed = 0; + + l = scheme_reverse(mrn->unmarshal_info); + for (; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + scheme_do_module_rename_unmarshal((Scheme_Object *)mrn, SCHEME_CAR(l), + modidx_shift_from, modidx_shift_to, + export_registry); + } + + if (sealed) + mrn->sealed = sealed; +} + +/******************** wrap manipulations ********************/ + +Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename) +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + Scheme_Object *wraps; + Scheme_Object *certs; + intptr_t lp; + + if (STX_KEY(stx) & STX_SUBSTX_FLAG) + preemptive_chunk(stx); + + /* relative order matters: chunk first, so that chunking + doesn't immediately throw away a chain cache */ + + maybe_add_chain_cache(stx); + + wraps = CONS(rename, stx->wraps); + if (STX_KEY(stx) & STX_SUBSTX_FLAG) + lp = stx->u.lazy_prefix + 1; + else + lp = 0; + + certs = stx->certs; + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); + stx->wraps = wraps; + stx->certs = certs; + + stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */ + + if (stx->certs) + phase_shift_certs((Scheme_Object *)stx, stx->wraps, 1); + + return (Scheme_Object *)stx; +} + +void scheme_load_delayed_syntax(struct Resolve_Prefix *rp, intptr_t i) +{ + Scheme_Object *stx; + int c; + + stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]), + (struct Scheme_Load_Delay *)SCHEME_CDR(rp->delay_info_rpair)); + rp->stxes[i] = stx; + c = SCHEME_INT_VAL(SCHEME_CAR(rp->delay_info_rpair)); + --c; + SCHEME_CAR(rp->delay_info_rpair) = scheme_make_integer(c); + if (!c) { + SCHEME_CDR(rp->delay_info_rpair) = NULL; + rp->delay_info_rpair = NULL; + } +} + +Scheme_Object *scheme_delayed_rename(Scheme_Object **o, intptr_t i) +{ + Scheme_Object *rename; + Resolve_Prefix *rp; + + rename = o[0]; + + if (!rename) return scheme_false; /* happens only with corrupted .zo! */ + + rp = (Resolve_Prefix *)o[1]; + + if (SCHEME_INTP(rp->stxes[i])) + scheme_load_delayed_syntax(rp, i); + + return scheme_add_rename(rp->stxes[i], rename); +} + +Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) +{ +#if 0 + WRAP_POS wl; + + /* Shortcut: there's a good chance that o already has the renaming rib */ + WRAP_POS_INIT(wl, ((Scheme_Stx *)o)->wraps); + if (!WRAP_POS_END_P(wl)) { + if (SAME_OBJ(rib, WRAP_POS_FIRST(wl))) { + return o; + } + } +#endif + + return scheme_add_rename(o, rib); +} + +Scheme_Object *scheme_add_rib_delimiter(Scheme_Object *o, Scheme_Object *ribs) +{ + Scheme_Object *s; + + s = scheme_alloc_small_object(); + s->type = scheme_rib_delimiter_type; + SCHEME_BOX_VAL(s) = ribs; + + return scheme_add_rename(o, s); +} + +static int is_in_rib_delim(Scheme_Object *envname, Scheme_Object *rib_delim) +{ + Scheme_Object *l = SCHEME_BOX_VAL(rib_delim); + Scheme_Lexical_Rib *rib; + + while (!SCHEME_NULLP(l)) { + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(l); + while (rib) { + if (rib->rename && SAME_OBJ(envname, SCHEME_VEC_ELS(rib->rename)[0])) + return 1; + rib = rib->next; + } + l = SCHEME_CDR(l); + } + return 0; +} + +static Scheme_Hash_Table *make_recur_table() +{ + if (quick_hash_table) { + GC_CAN_IGNORE Scheme_Hash_Table *t; + t = quick_hash_table; + quick_hash_table = NULL; + return t; + } else + return scheme_make_hash_table(SCHEME_hash_ptr); +} + +static void release_recur_table(Scheme_Hash_Table *free_id_recur) +{ + if (!free_id_recur->size && !quick_hash_table) { + quick_hash_table = free_id_recur; + } +} + +static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, + Scheme_Object *id, + Scheme_Object *orig_id, + int *_sealed, + Scheme_Hash_Table *free_id_recur) +{ + Scheme_Object *result; + Scheme_Object *modname; + Scheme_Object *nominal_modidx; + Scheme_Object *nominal_name, *nom2; + Scheme_Object *mod_phase; + Scheme_Object *src_phase_index; + Scheme_Object *nominal_src_phase; + Scheme_Object *lex_env; + Scheme_Object *rename_insp; + + if (scheme_hash_get(free_id_recur, id)) { + return id; + } + scheme_hash_set(free_id_recur, id, id); + + nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); + + modname = scheme_stx_module_name(free_id_recur, + &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, + &nominal_name, + &mod_phase, + &src_phase_index, + &nominal_src_phase, + &lex_env, + _sealed, + &rename_insp); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; + + if (!modname) + result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false)); + else if (SAME_OBJ(modname, scheme_undefined)) + result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), lex_env)); + else + result = scheme_extend_module_rename(mrn, + modname, + id, /* name in local context */ + orig_id, /* name in definition context */ + nominal_modidx, /* nominal source module */ + nominal_name, /* nominal import before local renaming */ + SCHEME_INT_VAL(mod_phase), /* phase of source defn */ + src_phase_index, /* nominal import phase */ + nominal_src_phase, /* nominal export phase */ + rename_insp, + 3); + + if (*_sealed) { + /* cache the result */ + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, id, result); + } + + return result; +} + +void scheme_install_free_id_rename(Scheme_Object *id, + Scheme_Object *orig_id, + Scheme_Object *rename_rib, + Scheme_Object *phase) +{ + Scheme_Object *v = NULL, *env, *r_id; + Scheme_Lexical_Rib *rib = NULL; + + if (rename_rib && (SCHEME_RENAMESP(rename_rib) || SCHEME_RENAMES_SETP(rename_rib))) { + /* Install a Module_Rename-level free-id=? rename, instead of at + the level of a lexical-rename. In this case, id is a symbol instead + of an identifier. */ + Module_Renames *rn; + + if (SCHEME_RENAMES_SETP(rename_rib)) + rename_rib = scheme_get_module_rename_from_set(rename_rib, phase, 1); + rn = (Module_Renames *)rename_rib; + + if (!rn->free_id_renames) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + rn->free_id_renames = ht; + } + + scheme_hash_set(rn->free_id_renames, id, orig_id); + + return; + } + + env = scheme_stx_moduleless_env(id); + + if (rename_rib) { + rib = (Scheme_Lexical_Rib *)rename_rib; + } else { + WRAP_POS wl; + + WRAP_POS_INIT(wl, ((Scheme_Stx *)id)->wraps); + while (!WRAP_POS_END_P(wl)) { + v = WRAP_POS_FIRST(wl); + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) { + break; + } if (SCHEME_RIBP(v)) { + rib = (Scheme_Lexical_Rib *)v; + while (rib) { + if (rib->rename) { + v = rib->rename; + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) + break; + v = NULL; + } + rib = rib->next; + } + } else + v = NULL; + WRAP_POS_INC(wl); + } + } + + while (v || rib) { + if (!v) { + while (rib) { + if (rib->rename) { + v = rib->rename; + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) + break; + v = NULL; + } + rib = rib->next; + } + } + + if (v) { + int i, sz; + + sz = SCHEME_RENAME_LEN(v); + for (i = 0; i < sz; i++) { + r_id = SCHEME_VEC_ELS(v)[i+2]; + if (SAME_OBJ(SCHEME_STX_SYM(r_id), SCHEME_STX_VAL(id))) { + /* Install rename: */ + env = SCHEME_VEC_ELS(v)[i+sz+2]; + if (SCHEME_PAIRP(env)) env = SCHEME_CAR(env); + env = CONS(env, CONS(orig_id, phase)); + SCHEME_VEC_ELS(v)[i+sz+2] = env; + return; + } + } + } + + v = NULL; + if (rib) rib = rib->next; + } +} + +Scheme_Object *scheme_stx_phase_shift_as_rename(intptr_t shift, Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Hash_Table *export_registry) +{ + if (shift || new_midx || export_registry) { + Scheme_Object *vec; + + if (last_phase_shift + && ((vec = SCHEME_BOX_VAL(last_phase_shift))) + && (SCHEME_VEC_ELS(vec)[0] == scheme_make_integer(shift)) + && (SCHEME_VEC_ELS(vec)[1] == (new_midx ? old_midx : scheme_false)) + && (SCHEME_VEC_ELS(vec)[2] == (new_midx ? new_midx : scheme_false)) + && (SCHEME_VEC_ELS(vec)[3] == (export_registry ? (Scheme_Object *)export_registry : scheme_false))) { + /* use the old one */ + } else { + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = scheme_make_integer(shift); + SCHEME_VEC_ELS(vec)[1] = (new_midx ? old_midx : scheme_false); + SCHEME_VEC_ELS(vec)[2] = (new_midx ? new_midx : scheme_false); + SCHEME_VEC_ELS(vec)[3] = (export_registry ? (Scheme_Object *)export_registry : scheme_false); + + last_phase_shift = scheme_box(vec); + } + + return last_phase_shift; + } else + return NULL; +} + +Scheme_Object *scheme_stx_phase_shift(Scheme_Object *stx, intptr_t shift, + Scheme_Object *old_midx, Scheme_Object *new_midx, + Scheme_Hash_Table *export_registry) +/* Shifts the phase on a syntax object in a module. A 0 shift might be + used just to re-direct relative module paths. new_midx might be + NULL to shift without redirection. And so on. */ +{ + Scheme_Object *ps; + + ps = scheme_stx_phase_shift_as_rename(shift, old_midx, new_midx, export_registry); + if (ps) + return scheme_add_rename(stx, ps); + else + return stx; +} + +void scheme_clear_shift_cache(void) +{ + last_phase_shift = NULL; +} + +static void phase_shift_certs(Scheme_Object *o, Scheme_Object *owner_wraps, int len) + /* Mutates o to change its certs, in the case that the first len + elements of owner_wraps includes any phase-shifting (i.e., + modidx-shifting) elements. */ +{ + Scheme_Object *l, *a, *modidx_shift_to = NULL, *modidx_shift_from = NULL, *vec, *src, *dest; + int i, j, cnt; + + for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { + cnt = ((Wrap_Chunk *)a)->len; + for (j = 0; j < cnt; j++) { + if (SCHEME_BOXP(((Wrap_Chunk *)a)->a[j])) { + vec = SCHEME_BOX_VAL(((Wrap_Chunk *)a)->a[j]); + src = SCHEME_VEC_ELS(vec)[1]; + dest = SCHEME_VEC_ELS(vec)[2]; + if (!modidx_shift_to) { + modidx_shift_to = dest; + } else if (!SAME_OBJ(modidx_shift_from, dest)) { + modidx_shift_to = scheme_modidx_shift(dest, + modidx_shift_from, + modidx_shift_to); + } + modidx_shift_from = src; + } + } + } else if (SCHEME_BOXP(a)) { + vec = SCHEME_BOX_VAL(a); + src = SCHEME_VEC_ELS(vec)[1]; + dest = SCHEME_VEC_ELS(vec)[2]; + if (!modidx_shift_to) { + modidx_shift_to = dest; + } else if (!SAME_OBJ(modidx_shift_from, dest)) { + modidx_shift_to = scheme_modidx_shift(dest, + modidx_shift_from, + modidx_shift_to); + } + modidx_shift_from = src; + } + } + + if (modidx_shift_from) { + Scheme_Cert *certs, *acerts, *icerts, *first = NULL, *last = NULL, *c; + Scheme_Object *nc; + int i; + + acerts = ACTIVE_CERTS(((Scheme_Stx *)o)); + icerts = INACTIVE_CERTS(((Scheme_Stx *)o)); + + /* Clone certs list, phase-shifting each cert */ + for (i = 0; i < 2; i++) { + int changed = 0; + + certs = (i ? acerts : icerts); + + first = last = NULL; + while (certs) { + a = scheme_modidx_shift(certs->modidx, modidx_shift_from, modidx_shift_to); + if (!SAME_OBJ(a, certs->modidx)) changed++; + c = cons_cert(certs->mark, a, certs->insp, certs->key, NULL); + c->mapped = certs->mapped; + c->depth = certs->depth; + if (first) + last->next = c; + else + first = c; + last = c; + certs = certs->next; + } + + if (changed) { + if (i) + acerts = first; + else + icerts = first; + } + } + + /* Even if icerts is NULL, may preserve the pair in ->certs, + to indicate no nested inactive certs: */ + { + int no_ia_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs) + && SCHEME_NO_INACTIVE_SUBS_P(((Scheme_Stx *)o)->certs)); + int no_a_sub = (SCHEME_RPAIRP(((Scheme_Stx *)o)->certs) + && SCHEME_NO_ACTIVE_SUBS_P(((Scheme_Stx *)o)->certs)); + if (icerts || no_ia_sub || no_a_sub) { + nc = scheme_make_raw_pair((Scheme_Object *)acerts, (Scheme_Object *)icerts); + if (no_ia_sub) + SCHEME_SET_NO_INACTIVE_SUBS(nc); + if (no_a_sub) + SCHEME_SET_NO_ACTIVE_SUBS(nc); + } else + nc = (Scheme_Object *)acerts; + + ((Scheme_Stx *)o)->certs = nc; + } + } +} + +static Scheme_Object *make_chunk(int len, Scheme_Object *owner_wraps) +/* Result is a single wrap element (possibly a chunk) or a list + of elements in reverse order. */ +{ + Wrap_Chunk *wc; + Scheme_Object *l, *a, *max_chunk_start_list = NULL, *ml; + int i, count = 0, j, max_chunk_size = 0, max_chunk_start_pos = 0; + + if (len > 1) { + for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { + j = ((Wrap_Chunk *)a)->len; + if (j > max_chunk_size) { + max_chunk_start_list = l; + max_chunk_start_pos = i; + max_chunk_size = j; + } + count += j; + } else if (SCHEME_NUMBERP(a)) { + if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l))) + count++; + else { + /* Skip canceling marks */ + i++; + l = SCHEME_CDR(l); + } + } else if (SCHEME_HASHTP(a)) { + /* Don't propagate chain-specific table */ + } else + count++; + } + + if ((max_chunk_size > 8) && ((max_chunk_size * 2) > count)) { + /* It's not worth copying a big existing chunk into + a new chunk. First copy over the part before new chunk, + then the new chunk, and finally the rest. */ + Scheme_Object *ml2; + if (max_chunk_start_pos) { + ml = make_chunk(max_chunk_start_pos, owner_wraps); + if (!SCHEME_PAIRP(ml) && !SCHEME_NULLP(ml)) + ml = scheme_make_pair(ml, scheme_null); + } else + ml = scheme_null; + ml = scheme_make_pair(SCHEME_CAR(max_chunk_start_list), ml); + if (max_chunk_start_pos + 1 < len) { + ml2 = make_chunk(len - 1 - max_chunk_start_pos, + SCHEME_CDR(max_chunk_start_list)); + if (!SCHEME_NULLP(ml2)) { + if (SCHEME_PAIRP(ml2)) + ml = scheme_append(ml2, ml); + else + ml = scheme_make_pair(ml2, ml); + } + } + } else { + if (!count) { + ml = scheme_null; /* everything disappeared! */ + } else { + wc = MALLOC_WRAP_CHUNK(count); + wc->type = scheme_wrap_chunk_type; + wc->len = count; + + ml = NULL; /* to make compiler happy */ + + j = 0; + for (i = 0, l = owner_wraps; i < len; i++, l = SCHEME_CDR(l)) { + a = SCHEME_CAR(l); + if (SAME_TYPE(SCHEME_TYPE(a), scheme_wrap_chunk_type)) { + int k, cl = ((Wrap_Chunk *)a)->len; + for (k = 0; k < cl; k++) { + wc->a[j++] = ((Wrap_Chunk *)a)->a[k]; + } + } else if (SCHEME_NUMBERP(a)) { + if ((i >= len-1) || !SAME_OBJ(a, SCHEME_CADR(l))) + wc->a[j++] = a; + else { + /* Skip canceling marks */ + i++; + l= SCHEME_CDR(l); + } + } else if (SCHEME_HASHTP(a)) { + /* Skip chain-specific table */ + } else + wc->a[j++] = a; + } + + if (count == 1) /* in case mark removal left only one */ + ml = wc->a[0]; + else + ml = (Scheme_Object *)wc; + } + } + } else { + ml = SCHEME_CAR(owner_wraps); + if (SCHEME_HASHTP(ml)) + return scheme_null; + } + + return ml; +} + +#define PREEMPTIVE_CHUNK_THRESHOLD 32 + +static void preemptive_chunk(Scheme_Stx *stx) +{ + int wl_count; + int new_count; + Scheme_Object *here_wraps, *ml; + + /* If the lazy prefix is long, transform it into a chunk. Probably, + some syntax object derived from this one will be unpacked, and + then the lazy prefix will need to be pushed down. + + This chunking fights somewhat with the chain-cache heuristic, + since a chain cache can't be included in a chunk. Still, the + combination seems to work better than either alone for deeply + nested scopes. + + It might also interact badly with simplication or marshaling, + since it decreases chain sharing. This is seems unlikely to + matter, since deeply nested syntax information will be expensive + in any case, and nodes in the wraps are still shared. */ + + wl_count = stx->u.lazy_prefix; + + if (wl_count > PREEMPTIVE_CHUNK_THRESHOLD) { + /* Chunk it */ + here_wraps = stx->wraps; + + ml = make_chunk(wl_count, here_wraps); + + if (SCHEME_PAIRP(ml) || SCHEME_NULLP(ml)) { + new_count = scheme_list_length(ml); + if (new_count == 1) + ml = SCHEME_CAR(ml); + } else { + new_count = 1; + } + + while (wl_count--) { + here_wraps = SCHEME_CDR(here_wraps); + } + wl_count = new_count; + + if (new_count == 1) + here_wraps = scheme_make_pair(ml, here_wraps); + else { + while (new_count--) { + here_wraps = scheme_make_pair(SCHEME_CAR(ml), here_wraps); + ml = SCHEME_CDR(ml); + } + } + + stx->wraps = here_wraps; + stx->u.lazy_prefix = wl_count; + } +} + +static Scheme_Object *propagate_wraps(Scheme_Object *o, + int len, Scheme_Object **_ml, + Scheme_Object *owner_wraps) +{ + int i; + Scheme_Object *ml, *a; + + /* Would adding the wraps generate a list equivalent to owner_wraps? + If so, use owner_wraps directly. But if len is too big, then it + takes too long to check, and so it's better to start chunking. */ + if (len < 128) { + Scheme_Stx *stx = (Scheme_Stx *)o; + Scheme_Object *p1 = owner_wraps; + Scheme_Object *certs; + + /* Find list after |wl| items in owner_wraps: */ + for (i = 0; i < len; i++) { + p1 = SCHEME_CDR(p1); + } + /* p1 is the list after wl... */ + + if (SAME_OBJ(stx->wraps, p1)) { + /* So, we can use owner_wraps directly instead of building + new wraps. */ + intptr_t lp; + + if (STX_KEY(stx) & STX_SUBSTX_FLAG) + lp = stx->u.lazy_prefix + len; + else + lp = 0; + + certs = stx->certs; + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); + stx->wraps = owner_wraps; + stx->u.lazy_prefix = lp; /* same as zeroing cache if no SUBSTX */ + stx->certs = certs; + + if (stx->certs) + phase_shift_certs((Scheme_Object *)stx, owner_wraps, len); + + return (Scheme_Object *)stx; + } + } + + ml = *_ml; + if (!ml) { + ml = make_chunk(len, owner_wraps); + *_ml = ml; + } + + if (SCHEME_PAIRP(ml)) { + while (SCHEME_PAIRP(ml)) { + a = SCHEME_CAR(ml); + if (SCHEME_NUMBERP(a)) { + o = scheme_add_remove_mark(o, a); + } else { + o = scheme_add_rename(o, a); + } + ml = SCHEME_CDR(ml); + } + } else if (SCHEME_NUMBERP(ml)) + o = scheme_add_remove_mark(o, ml); + else if (SCHEME_NULLP(ml)) { + /* nothing to add */ + } else + o = scheme_add_rename(o, ml); + + if (((Scheme_Stx *)o)->certs) + phase_shift_certs(o, owner_wraps, len); + + return o; +} + +int scheme_stx_certified(Scheme_Object *stx, Scheme_Object *extra_certs, + Scheme_Object *home_modidx, Scheme_Object *home_insp) +{ + Scheme_Cert *certs = ACTIVE_CERTS((Scheme_Stx *)stx); + Scheme_Object *cert_modidx, *a, *b; + + do { + while (certs) { + if (!scheme_module_protected_wrt(home_insp, certs->insp)) { + if (home_modidx) { + if (SCHEME_FALSEP(certs->modidx)) + cert_modidx = home_modidx; + else + cert_modidx = certs->modidx; + + a = scheme_module_resolve(home_modidx, 0); + b = scheme_module_resolve(cert_modidx, 0); + } else + a = b = NULL; + + if (SAME_OBJ(a, b)) { + /* Found a certification. Does this identifier have the + associated mark? */ + if (includes_mark(((Scheme_Stx *)stx)->wraps, certs->mark)) + return 1; + } + } + certs = certs->next; + } + if (extra_certs) { + certs = (Scheme_Cert *)extra_certs; + extra_certs = NULL; + } + } while (certs); + + return 0; +} + +static Scheme_Cert *cons_cert(Scheme_Object *mark, Scheme_Object *modidx, + Scheme_Object *insp, Scheme_Object *key, + Scheme_Cert *next_cert) +{ + Scheme_Cert *cert; + + cert = MALLOC_ONE_RT(Scheme_Cert); + cert->iso.so.type = scheme_certifications_type; + cert->mark = mark; + cert->modidx = modidx; + cert->insp = insp; + cert->key = key; + cert->next = next_cert; + cert->depth = (next_cert ? next_cert->depth + 1 : 1); + + if (!key && (!next_cert || CERT_NO_KEY(next_cert))) { + CERT_SET_NO_KEY(cert); + } + + return cert; +} + +#ifdef DO_STACK_CHECK +static void make_mapped(Scheme_Cert *cert); +static Scheme_Object *make_mapped_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Cert *cert = (Scheme_Cert *)p->ku.k.p1; + + p->ku.k.p1 = NULL; + + make_mapped(cert); + + return scheme_void; +} +#endif + +static void make_mapped(Scheme_Cert *cert) +{ + Scheme_Cert *stop, *c2; + Scheme_Object *pr; + Scheme_Hash_Table *ht; + + if (cert->mapped) + return; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)cert; + scheme_handle_stack_overflow(make_mapped_k); + return; + } + } +#endif + SCHEME_USE_FUEL(1); + + if (cert->depth == 16) { + stop = NULL; + } else { + for (stop = cert->next; + stop && ((stop->depth & cert->depth) != stop->depth); + stop = stop->next) { + } + if (stop) + make_mapped(stop); + } + + /* Check whether an `eq?' table will work: */ + for (c2 = cert; c2 != stop; c2 = c2->next) { + if (c2->key) + break; + if (!SCHEME_INTP(c2->mark)) + break; + } + + if (c2 == stop) + ht = scheme_make_hash_table(SCHEME_hash_ptr); + else + ht = scheme_make_hash_table_equal(); + + pr = scheme_make_raw_pair((Scheme_Object *)ht, (Scheme_Object *)stop); + cert->mapped = pr; + + for (; cert != stop; cert = cert->next) { + if (cert->key) + pr = scheme_make_pair(cert->mark, cert->key); + else + pr = cert->mark; + scheme_hash_set_atomic(ht, pr, scheme_true); + } +} + +static int cert_in_chain(Scheme_Object *mark, Scheme_Object *key, Scheme_Cert *cert) +{ + Scheme_Object *hkey = key ? NULL : mark; + Scheme_Hash_Table *ht; + + while (cert) { + if (!(cert->depth & 0xF)) { + make_mapped(cert); + + ht = (Scheme_Hash_Table *)SCHEME_CAR(cert->mapped); + cert = (Scheme_Cert *)SCHEME_CDR(cert->mapped); + + if (!hkey) + hkey = scheme_make_pair(mark, key); + + if (scheme_hash_get_atomic(ht, hkey)) + return 1; + } else if (SAME_OBJ(cert->mark, mark) + && SAME_OBJ(cert->key, key)) { + return 1; + } else + cert = cert->next; + } + + return 0; +} + +static Scheme_Cert *append_certs(Scheme_Cert *a, Scheme_Cert *b) +{ + Scheme_Cert *c; + + if (!a) return b; + if (!b) return a; + + if (a->depth < b->depth) { + c = a; + a = b; + b = c; + } + + c = a; + if (b->depth > (a->depth >> 1)) { + /* There's a good chance that b shares a tail with a, + so check for that, and b is large enough relative to + a that it's worth iterating down to b's depth in a: */ + while (c->depth > b->depth) { + c = c->next; + } + } + + for (; b; b = b->next) { + if (b == c) break; + if (!cert_in_chain(b->mark, b->key, a)) + a = cons_cert(b->mark, b->modidx, b->insp, b->key, a); + c = c->next; + } + + return a; +} + +static Scheme_Object *add_certs(Scheme_Object *o, Scheme_Cert *certs, Scheme_Object *use_key, int active) +{ + Scheme_Cert *orig_certs, *cl, *now_certs, *next_certs, *check_tail; + Scheme_Stx *stx = (Scheme_Stx *)o, *res; + Scheme_Object *pr; + int shortcut; + + if (!stx->certs) { + if (!certs) + return (Scheme_Object *)stx; + + if (use_key) { + for (cl = certs; cl; cl = cl->next) { + if (!SAME_OBJ(cl->key, use_key)) + break; + } + } else + cl = NULL; + + if (!cl) { + res = (Scheme_Stx *)scheme_make_stx(stx->val, + stx->srcloc, + stx->props); + res->wraps = stx->wraps; + res->u.lazy_prefix = stx->u.lazy_prefix; + if (active) + res->certs = (Scheme_Object *)certs; + else { + pr = scheme_make_raw_pair(NULL, (Scheme_Object *)certs); + res->certs = pr; + } + return (Scheme_Object *)res; + } + } + + if (active) + orig_certs = ACTIVE_CERTS(stx); + else + orig_certs = INACTIVE_CERTS(stx); + now_certs = orig_certs; + + shortcut = 0; + if (now_certs && certs && !use_key && CERT_NO_KEY(certs)) { + if (now_certs->depth < certs->depth) { + /* We can add now_certs onto certs, instead of the other + way around. */ + now_certs = certs; + certs = orig_certs; + } + } + + check_tail = now_certs; + if (check_tail && certs + && (certs->depth > (check_tail->depth >> 1))) { + while (check_tail->depth > certs->depth) { + check_tail = check_tail->next; + } + } + + for (; certs; certs = next_certs) { + next_certs = certs->next; + if (check_tail && (check_tail->depth > certs->depth)) + check_tail = check_tail->next; + if (SAME_OBJ(certs, check_tail)) { + /* tails match --- no need to keep checking */ + break; + } + if (!cert_in_chain(certs->mark, use_key, now_certs)) { + if (!now_certs && !use_key && (shortcut || CERT_NO_KEY(certs))) { + now_certs = certs; + next_certs = NULL; + } else { + now_certs = cons_cert(certs->mark, certs->modidx, certs->insp, use_key, + now_certs); + } + } + } + + if (!SAME_OBJ(now_certs, orig_certs)) { + res = (Scheme_Stx *)scheme_make_stx(stx->val, + stx->srcloc, + stx->props); + res->wraps = stx->wraps; + res->u.lazy_prefix = stx->u.lazy_prefix; + if (!active) { + pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)orig_certs); + res->certs = pr; + if (stx->certs && SCHEME_RPAIRP(stx->certs)) { + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); + } + } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) { + pr = scheme_make_raw_pair((Scheme_Object *)orig_certs, SCHEME_CDR(stx->certs)); + res->certs = pr; + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); + } else + res->certs = (Scheme_Object *)orig_certs; + stx = res; + + if (!active) { + SCHEME_CDR(stx->certs) = (Scheme_Object *)now_certs; + } else if (stx->certs && SCHEME_RPAIRP(stx->certs)) + SCHEME_CAR(stx->certs) = (Scheme_Object *)now_certs; + else + stx->certs = (Scheme_Object *)now_certs; + } + + return (Scheme_Object *)stx; +} + +Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *certs) + /* Also lifts existing inactive certs to the top. */ +{ + o = lift_inactive_certs(o, 0); + + return add_certs(o, (Scheme_Cert *)certs, NULL, 0); +} + +Scheme_Object *scheme_stx_propagate_inactive_certs(Scheme_Object *o, Scheme_Object *orig) +{ + Scheme_Cert *certs; + + certs = INACTIVE_CERTS((Scheme_Stx *)orig); + + if (certs) + return scheme_stx_add_inactive_certs(o, (Scheme_Object *)certs); + else + return o; +} + +Scheme_Object *scheme_stx_extract_certs(Scheme_Object *o, Scheme_Object *base_certs) +{ + return (Scheme_Object *)append_certs((Scheme_Cert *)base_certs, + ACTIVE_CERTS((Scheme_Stx *)o)); +} + +Scheme_Object *scheme_stx_cert(Scheme_Object *o, Scheme_Object *mark, Scheme_Env *menv, + Scheme_Object *plus_stx_or_certs, Scheme_Object *key, + int active) + /* If `name' is module-bound, add the module's certification. + Also copy any certifications from plus_stx. + If active and mark is non-NULL, make inactive certificates active. + Existing inactive are lifted when adding from plus_stx_or_certs. */ +{ + if (mark && active) { + o = scheme_stx_activate_certs(o); + } + + if (plus_stx_or_certs) { + Scheme_Cert *certs; + if (SCHEME_STXP(plus_stx_or_certs)) + certs = ACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs); + else + certs = (Scheme_Cert *)plus_stx_or_certs; + if (certs) { + if (!active) + o = lift_inactive_certs(o, 0); + o = add_certs(o, certs, key, active); + } + /* Also copy over inactive certs, if any */ + if (SCHEME_STXP(plus_stx_or_certs)) { + o = lift_inactive_certs(o, 0); + o = add_certs(o, INACTIVE_CERTS((Scheme_Stx *)plus_stx_or_certs), key, 0); + } + } + + if (menv && !menv->module->no_cert) { + Scheme_Stx *stx = (Scheme_Stx *)o, *res; + Scheme_Cert *cert; + + res = (Scheme_Stx *)scheme_make_stx(stx->val, + stx->srcloc, + stx->props); + res->wraps = stx->wraps; + res->u.lazy_prefix = stx->u.lazy_prefix; + + if (SCHEME_FALSEP(mark)) { + /* Need to invent a certificate-only mark and apply it */ + mark = scheme_new_mark(); + mark = negate_mark(mark); + res = (Scheme_Stx *)scheme_add_remove_mark((Scheme_Object *)res, mark); + } + + if (active) + cert = ACTIVE_CERTS(stx); + else + cert = INACTIVE_CERTS(stx); + + cert = cons_cert(mark, menv->link_midx ? menv->link_midx : menv->module->me->src_modidx, + menv->module->insp, key, cert); + + if (active) { + if (stx->certs && SCHEME_RPAIRP(stx->certs)) { + Scheme_Object *pr; + pr = scheme_make_raw_pair((Scheme_Object *)cert, SCHEME_CDR(stx->certs)); + res->certs = pr; + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); + } else + res->certs = (Scheme_Object *)cert; + } else { + Scheme_Object *pr; + pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)cert); + res->certs = pr; + if (stx->certs && SCHEME_RPAIRP(stx->certs)) { + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(pr); + if (SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(pr); + } + } + + o = (Scheme_Object *)res; + } + + return o; +} + +Scheme_Object *scheme_stx_content(Scheme_Object *o) + /* Propagates wraps while getting a syntax object's content. */ +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + + /* The fast-past tests are duplicated in jit.c. */ + + if ((STX_KEY(stx) & STX_SUBSTX_FLAG) && stx->u.lazy_prefix) { + Scheme_Object *v = stx->val, *result; + Scheme_Object *here_wraps; + Scheme_Object *ml = NULL; + int wl_count = 0; + + here_wraps = stx->wraps; + wl_count = stx->u.lazy_prefix; + stx->u.lazy_prefix = 0; + + if (SCHEME_PAIRP(v)) { + Scheme_Object *last = NULL, *first = NULL; + + while (SCHEME_PAIRP(v)) { + Scheme_Object *p; + result = propagate_wraps(SCHEME_CAR(v), wl_count, &ml, here_wraps); + p = scheme_make_pair(result, scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); + } + if (!SCHEME_NULLP(v)) { + result = propagate_wraps(v, wl_count, &ml, here_wraps); + if (last) + SCHEME_CDR(last) = result; + else + first = result; + } + v = first; + } else if (SCHEME_BOXP(v)) { + result = propagate_wraps(SCHEME_BOX_VAL(v), wl_count, &ml, here_wraps); + v = scheme_box(result); + } else if (SCHEME_VECTORP(v)) { + Scheme_Object *v2; + int size = SCHEME_VEC_SIZE(v), i; + + v2 = scheme_make_vector(size, NULL); + + for (i = 0; i < size; i++) { + result = propagate_wraps(SCHEME_VEC_ELS(v)[i], wl_count, &ml, here_wraps); + SCHEME_VEC_ELS(v2)[i] = result; + } + + v = v2; + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; + Scheme_Object *key, *val; + int i; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); + + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = propagate_wraps(val, wl_count, &ml, here_wraps); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + v = (Scheme_Object *)ht2; + } else if (prefab_p(v)) { + Scheme_Structure *s = (Scheme_Structure *)v; + Scheme_Object *r; + int size, i; + + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); + + size = s->stype->num_slots; + for (i = 0; i < size; i++) { + r = propagate_wraps(s->slots[i], wl_count, &ml, here_wraps); + s->slots[i] = r; + } + + v = (Scheme_Object *)s; + } + + stx->val = v; + } + + return stx->val; +} + +Scheme_Object *scheme_stx_extract_marks(Scheme_Object *stx) +/* Does not include negative marks */ +{ + WRAP_POS awl; + Scheme_Object *acur_mark, *p, *marks = scheme_null; + + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + + while (1) { + /* Skip over renames, immediately-canceled marks, and negative marks: */ + acur_mark = NULL; + while (1) { + if (WRAP_POS_END_P(awl)) + break; + p = WRAP_POS_FIRST(awl); + if (SCHEME_NUMBERP(p) && IS_POSMARK(p)) { + if (acur_mark) { + if (SAME_OBJ(acur_mark, p)) { + acur_mark = NULL; + WRAP_POS_INC(awl); + } else + break; + } else { + acur_mark = p; + WRAP_POS_INC(awl); + } + } else { + WRAP_POS_INC(awl); + } + } + + if (acur_mark) { + if (SCHEME_PAIRP(marks) && SAME_OBJ(acur_mark, SCHEME_CAR(marks))) + marks = SCHEME_CDR(marks); + else + marks = scheme_make_pair(acur_mark, marks); + } + + if (WRAP_POS_END_P(awl)) + return scheme_reverse(marks); + } +} + +Scheme_Object *scheme_stx_strip_module_context(Scheme_Object *_stx) +{ + Scheme_Stx *stx = (Scheme_Stx *)_stx; + WRAP_POS awl; + int mod_ctx_count = 0, skipped = 0; + Scheme_Object *v; + Wrap_Chunk *chunk; + + /* Check for module context, first: */ + WRAP_POS_INIT(awl, stx->wraps); + while (!WRAP_POS_END_P(awl)) { + v = WRAP_POS_FIRST(awl); + if (SCHEME_RENAMESP(v) || SCHEME_BOXP(v) || SCHEME_RENAMES_SETP(v)) { + mod_ctx_count++; + } + WRAP_POS_INC(awl); + skipped++; + } + + if (!mod_ctx_count) + return _stx; + + if (mod_ctx_count == skipped) { + /* Everything was a module context? An unlikely but easy case. */ + return scheme_make_stx(stx->val, stx->srcloc, stx->props); + } else { + /* Copy everything else into a new chunk. */ + chunk = MALLOC_WRAP_CHUNK((skipped - mod_ctx_count)); + chunk->type = scheme_wrap_chunk_type; + chunk->len = skipped - mod_ctx_count; + skipped = 0; + WRAP_POS_INIT(awl, stx->wraps); + while (!WRAP_POS_END_P(awl)) { + v = WRAP_POS_FIRST(awl); + if (!SCHEME_RENAMESP(v) && !SCHEME_BOXP(v) && !SCHEME_RENAMES_SETP(v)) { + chunk->a[skipped] = v; + skipped++; + } + WRAP_POS_INC(awl); + } + + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); + v = scheme_make_pair((Scheme_Object *)chunk, scheme_null); + stx->wraps = v; + return (Scheme_Object *)stx; + } +} + +#ifdef DO_STACK_CHECK +static Scheme_Object *stx_strip_certs_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Cert **cp = (Scheme_Cert **)p->ku.k.p2; + int active = p->ku.k.i1; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + return stx_strip_certs(o, cp, active); +} +#endif + +static Scheme_Object *stx_strip_certs(Scheme_Object *o, Scheme_Cert **cp, int active) +{ +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + Scheme_Cert **_cp; + _cp = MALLOC_N(Scheme_Cert*, 1); + *_cp = *cp; + p->ku.k.p1 = (void *)o; + p->ku.k.p2 = (void *)_cp; + p->ku.k.i1 = active; + o = scheme_handle_stack_overflow(stx_strip_certs_k); + *cp = *_cp; + return o; + } + } +#endif + SCHEME_USE_FUEL(1); + + if (SCHEME_PAIRP(o)) { + Scheme_Object *a, *d; + a = stx_strip_certs(SCHEME_CAR(o), cp, active); + d = stx_strip_certs(SCHEME_CDR(o), cp, active); + if (SAME_OBJ(a, SCHEME_CAR(o)) + && SAME_OBJ(d, SCHEME_CDR(o))) + return o; + return ICONS(a, d); + } else if (SCHEME_NULLP(o)) { + return o; + } else if (SCHEME_BOXP(o)) { + Scheme_Object *c; + c = stx_strip_certs(SCHEME_BOX_VAL(o), cp, active); + if (SAME_OBJ(c, SCHEME_BOX_VAL(o))) + return o; + o = scheme_box(c); + SCHEME_SET_IMMUTABLE(o); + return o; + } else if (SCHEME_VECTORP(o)) { + Scheme_Object *e = NULL, *v2; + int size = SCHEME_VEC_SIZE(o), i, j; + + for (i = 0; i < size; i++) { + e = stx_strip_certs(SCHEME_VEC_ELS(o)[i], cp, active); + if (!SAME_OBJ(e, SCHEME_VEC_ELS(o)[i])) + break; + } + + if (i == size) + return o; + + v2 = scheme_make_vector(size, NULL); + + for (j = 0; j < i; j++) { + SCHEME_VEC_ELS(v2)[j] = SCHEME_VEC_ELS(o)[j]; + } + SCHEME_VEC_ELS(v2)[i] = e; + for (i++; i < size; i++) { + e = stx_strip_certs(SCHEME_VEC_ELS(o)[i], cp, active); + SCHEME_VEC_ELS(v2)[i] = e; + } + + SCHEME_SET_IMMUTABLE(v2); + return v2; + } else if (SCHEME_HASHTRP(o)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)o, *ht2; + Scheme_Object *key = NULL, *val, *e, *jkey; + int i, j; + + j = scheme_hash_tree_next(ht, -1); + while (j != -1) { + scheme_hash_tree_index(ht, j, &key, &val); + e = stx_strip_certs(val, cp, active); + if (!SAME_OBJ(e, val)) + break; + j = scheme_hash_tree_next(ht, j); + } + + if (j == -1) + return o; + jkey = key; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); + + i = scheme_hash_tree_next(ht, -1); + while (i != j) { + scheme_hash_tree_index(ht, i, &key, &val); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + ht2 = scheme_hash_tree_set(ht2, key, e); + i = scheme_hash_tree_next(ht, i); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = stx_strip_certs(val, cp, active); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + return (Scheme_Object *)ht2; + } else if (prefab_p(o)) { + Scheme_Object *e = NULL; + Scheme_Structure *s = (Scheme_Structure *)o; + int i, size = s->stype->num_slots; + + for (i = 0; i < size; i++) { + e = stx_strip_certs(s->slots[i], cp, active); + if (!SAME_OBJ(e, s->slots[i])) + break; + } + + if (i == size) + return o; + + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); + s->slots[i] = e; + + for (i++; i < size; i++) { + e = stx_strip_certs(s->slots[i], cp, active); + s->slots[i] = e; + } + + return (Scheme_Object *)s; + } else if (SCHEME_STXP(o)) { + Scheme_Stx *stx = (Scheme_Stx *)o; + + if ((!active && INACTIVE_CERTS(stx)) + || (active && ACTIVE_CERTS(stx))) { + Scheme_Object *np, *v; + Scheme_Stx *res; + Scheme_Cert *certs; + + if ((!active && SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + || (active && stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs))) { + /* No sub-object has other [in]active certs */ + v = stx->val; + } else { + v = stx_strip_certs(stx->val, cp, active); + } + + res = (Scheme_Stx *)scheme_make_stx(v, + stx->srcloc, + stx->props); + res->wraps = stx->wraps; + res->u.lazy_prefix = stx->u.lazy_prefix; + if (!active) { + if (!ACTIVE_CERTS(stx)) { + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + np = no_nested_certs; + else + np = no_nested_inactive_certs; + } else { + np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); + SCHEME_SET_NO_INACTIVE_SUBS(np); + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_ACTIVE_SUBS(np); + } + } else { + if (!INACTIVE_CERTS(stx)) { + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + np = no_nested_certs; + else + np = no_nested_active_certs; + } else { + np = scheme_make_raw_pair(NULL, (Scheme_Object *)INACTIVE_CERTS(stx)); + SCHEME_SET_NO_ACTIVE_SUBS(np); + if (SCHEME_NO_INACTIVE_SUBS_P(stx->certs)) + SCHEME_SET_NO_INACTIVE_SUBS(np); + } + } + res->certs = np; + + certs = append_certs((active ? ACTIVE_CERTS(stx) : INACTIVE_CERTS(stx)), *cp); + *cp = certs; + + return (Scheme_Object *)res; + } else if (stx->certs + && SCHEME_RPAIRP(stx->certs) + && (active + ? SCHEME_NO_ACTIVE_SUBS_P(stx->certs) + : SCHEME_NO_INACTIVE_SUBS_P(stx->certs))) { + /* Explicit pair, but no [in]active certs anywhere in this object. */ + return (Scheme_Object *)stx; + } else { + Scheme_Stx *res; + Scheme_Object *prev; + + o = stx_strip_certs(stx->val, cp, active); + + if (!SAME_OBJ(o, stx->val)) { + res = (Scheme_Stx *)scheme_make_stx(o, + stx->srcloc, + stx->props); + res->wraps = stx->wraps; + res->u.lazy_prefix = stx->u.lazy_prefix; + } else { + /* No new syntax object, but record the absence of certificates in + sub-parts: */ + res = stx; + } + + prev = stx->certs; + if (!active) { + if (ACTIVE_CERTS(stx)) { + Scheme_Object *np; + np = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), NULL); + res->certs = np; + SCHEME_SET_NO_INACTIVE_SUBS(np); + if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_ACTIVE_SUBS_P(prev)) + SCHEME_SET_NO_ACTIVE_SUBS(np); + } else if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_ACTIVE_SUBS_P(prev)) + res->certs = no_nested_certs; + else + res->certs = no_nested_inactive_certs; + } else { + if (INACTIVE_CERTS(stx)) { + Scheme_Object *np; + np = scheme_make_raw_pair(NULL, (Scheme_Object *)INACTIVE_CERTS(stx)); + res->certs = np; + SCHEME_SET_NO_ACTIVE_SUBS(np); + if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_INACTIVE_SUBS_P(prev)) + SCHEME_SET_NO_INACTIVE_SUBS(np); + } else if (prev && SCHEME_RPAIRP(prev) && SCHEME_NO_INACTIVE_SUBS_P(prev)) + res->certs = no_nested_certs; + else + res->certs = no_nested_active_certs; + } + + return (Scheme_Object *)res; + } + } else + return o; +} + +static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active) +{ + Scheme_Cert *certs = NULL; + + o = stx_strip_certs(o, &certs, 0); + + if (certs) + o = add_certs(o, certs, NULL, as_active); + + return o; +} + +Scheme_Object *scheme_stx_activate_certs(Scheme_Object *o) +{ + return lift_inactive_certs(o, 1); +} + +Scheme_Object *scheme_stx_lift_active_certs(Scheme_Object *o) +{ + Scheme_Cert *certs = NULL; + Scheme_Stx *stx = (Scheme_Stx *)o; + + if (stx->certs && SCHEME_RPAIRP(stx->certs) && SCHEME_NO_ACTIVE_SUBS_P(stx->certs)) + return o; + + o = stx_strip_certs(o, &certs, 1); + + if (certs) + o = add_certs(o, certs, NULL, 1); + + return o; +} + +int scheme_stx_has_empty_wraps(Scheme_Object *o) +{ + WRAP_POS awl; + Scheme_Object *mark = NULL, *v; + + WRAP_POS_INIT(awl, ((Scheme_Stx *)o)->wraps); + while (!WRAP_POS_END_P(awl)) { + v = WRAP_POS_FIRST(awl); + if (mark) { + if (!SAME_OBJ(mark, v)) + return 0; + mark = NULL; + } else + mark = v; + WRAP_POS_INC(awl); + } + + return !mark; +} + +/*========================================================================*/ +/* stx comparison */ +/*========================================================================*/ + +/* If no marks and no rename with this set's tag, + then it was an unmarked-but-actually-introduced id. */ + +static Scheme_Object *check_floating_id(Scheme_Object *stx) +{ + /* If `a' has a mzMOD_RENAME_MARKED rename with no following + mzMOD_RENAME_NORMAL using the same set tag, and if there are no + marks after the mzMOD_RENAME_MARKED rename, then we've hit a + corner case: an identifier that was introduced by macro expansion + but marked so that it appears to be original. To ensure that it + gets a generated symbol in the MOD_RENAME_MARKED table, give it a + "floating" binding: scheme_void. This is a rare case, and it more + likely indicates a buggy macro than anything else. */ + WRAP_POS awl; + Scheme_Object *cur_mark = NULL, *searching_identity = NULL, *a; + int no_mark_means_floating = 0; + + WRAP_POS_INIT(awl, ((Scheme_Stx *)stx)->wraps); + + while (!WRAP_POS_END_P(awl)) { + + a = WRAP_POS_FIRST(awl); + + if (SCHEME_RENAMESP(a) + || SCHEME_RENAMES_SETP(a)) { + int kind; + Scheme_Object *set_identity; + + if (SCHEME_RENAMESP(a)) { + Module_Renames *mrn = (Module_Renames *)a; + + kind = mrn->kind; + set_identity = mrn->set_identity; + } else { + Module_Renames_Set *mrns = (Module_Renames_Set *)a; + + kind = mrns->kind; + set_identity = mrns->set_identity; + } + + if (SAME_OBJ(set_identity, searching_identity)) + searching_identity = NULL; + + if (searching_identity) + no_mark_means_floating = 1; + + if (kind == mzMOD_RENAME_MARKED) + searching_identity = set_identity; + else + searching_identity = NULL; + + } else if (SCHEME_MARKP(a)) { + if (SAME_OBJ(a, cur_mark)) + cur_mark = 0; + else { + if (cur_mark) { + no_mark_means_floating = 0; + searching_identity = NULL; + } + cur_mark = a; + } + } + + WRAP_POS_INC(awl); + } + + if (cur_mark) { + no_mark_means_floating = 0; + searching_identity = NULL; + } + + if (searching_identity || no_mark_means_floating) + return scheme_void; + + return scheme_false; +} + +#define EXPLAIN_RESOLVE 0 +#if EXPLAIN_RESOLVE +int scheme_explain_resolves = 0; +# define EXPLAIN(x) if (scheme_explain_resolves) { x; } +#else +# define EXPLAIN(x) /* empty */ +#endif + +static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) +/* Compares the marks in two wraps lists. A result of 2 means that the + result depended on a barrier env. For a rib-based renaming, we need + to check only up to the rib, and the barrier effect important for + when a rib-based renaming is layered with another renaming (such as + when an internal-definition-base local-expand is used to form a new + set of bindings, as in the unit form); simplification cleans up the + layers, so that we only need to check in ribs. */ +{ + WRAP_POS awl; + WRAP_POS bwl; + Scheme_Object *acur_mark, *bcur_mark; +# define FAST_STACK_SIZE 4 + Scheme_Object *a_mark_stack_fast[FAST_STACK_SIZE], *b_mark_stack_fast[FAST_STACK_SIZE]; + Scheme_Object **a_mark_stack = a_mark_stack_fast, **b_mark_stack = b_mark_stack_fast, **naya; + int a_mark_cnt = 0, a_mark_size = FAST_STACK_SIZE, b_mark_cnt = 0, b_mark_size = FAST_STACK_SIZE; + int used_barrier = 0; + + WRAP_POS_COPY(awl, *_awl); + WRAP_POS_COPY(bwl, *_bwl); + + /* A simple way to compare marks would be to make two lists of + marks. The loop below attempts to speed up that process by + discovering common and canceled marks early, so they can be + omitted from the lists. The "stack" arrays accumulate the parts + of the list that can't be skipped that way. */ + + while (1) { + /* Skip over renames and canceled marks: */ + acur_mark = NULL; + while (1) { /* loop for canceling stack */ + /* this loop handles immediately canceled marks */ + while (1) { + if (WRAP_POS_END_P(awl)) + break; + if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl)) && IS_POSMARK(WRAP_POS_FIRST(awl))) { + if (acur_mark) { + if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { + acur_mark = NULL; + WRAP_POS_INC(awl); + } else + break; + } else { + acur_mark = WRAP_POS_FIRST(awl); + WRAP_POS_INC(awl); + } + } else if (SCHEME_RIBP(WRAP_POS_FIRST(awl))) { + if (SCHEME_FALSEP(barrier_env)) { + WRAP_POS_INC(awl); + } else { + /* See if the barrier environment is in this rib. */ + Scheme_Lexical_Rib *rib; + rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(awl); + for (rib = rib->next; rib; rib = rib->next) { + if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) + break; + } + if (!rib) { + WRAP_POS_INC(awl); + } else { + WRAP_POS_INIT_END(awl); + used_barrier = 1; + } + } + } else { + WRAP_POS_INC(awl); + } + } + /* Maybe cancel a mark on the stack */ + if (acur_mark && a_mark_cnt) { + if (SAME_OBJ(acur_mark, a_mark_stack[a_mark_cnt - 1])) { + --a_mark_cnt; + if (a_mark_cnt) { + acur_mark = a_mark_stack[a_mark_cnt - 1]; + --a_mark_cnt; + break; + } else + acur_mark = NULL; + } else + break; + } else + break; + } + + bcur_mark = NULL; + while (1) { /* loop for canceling stack */ + while (1) { + if (WRAP_POS_END_P(bwl)) + break; + if (SCHEME_NUMBERP(WRAP_POS_FIRST(bwl)) && IS_POSMARK(WRAP_POS_FIRST(bwl))) { + if (bcur_mark) { + if (SAME_OBJ(bcur_mark, WRAP_POS_FIRST(bwl))) { + bcur_mark = NULL; + WRAP_POS_INC(bwl); + } else + break; + } else { + bcur_mark = WRAP_POS_FIRST(bwl); + WRAP_POS_INC(bwl); + } + } else if (SCHEME_RIBP(WRAP_POS_FIRST(bwl))) { + if (SCHEME_FALSEP(barrier_env)) { + WRAP_POS_INC(bwl); + } else { + /* See if the barrier environment is in this rib. */ + Scheme_Lexical_Rib *rib; + rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(bwl); + for (rib = rib->next; rib; rib = rib->next) { + if (SAME_OBJ(SCHEME_VEC_ELS(rib->rename)[0], barrier_env)) + break; + } + if (!rib) { + WRAP_POS_INC(bwl); + } else { + WRAP_POS_INIT_END(bwl); + used_barrier = 1; + } + } + } else { + WRAP_POS_INC(bwl); + } + } + /* Maybe cancel a mark on the stack */ + if (bcur_mark && b_mark_cnt) { + if (SAME_OBJ(bcur_mark, b_mark_stack[b_mark_cnt - 1])) { + --b_mark_cnt; + if (b_mark_cnt) { + bcur_mark = b_mark_stack[b_mark_cnt - 1]; + --b_mark_cnt; + break; + } else + bcur_mark = NULL; + } else + break; + } else + break; + } + + /* Same mark? */ + if (a_mark_cnt || b_mark_cnt || !SAME_OBJ(acur_mark, bcur_mark)) { + /* Not the same, so far; push onto stacks in case they're + cancelled later */ + if (acur_mark) { + if (a_mark_cnt >= a_mark_size) { + a_mark_size *= 2; + naya = MALLOC_N(Scheme_Object*, a_mark_size); + memcpy(naya, a_mark_stack, sizeof(Scheme_Object *)*a_mark_cnt); + a_mark_stack = naya; + } + a_mark_stack[a_mark_cnt++] = acur_mark; + } + if (bcur_mark) { + if (b_mark_cnt >= b_mark_size) { + b_mark_size *= 2; + naya = MALLOC_N(Scheme_Object*, b_mark_size); + memcpy(naya, b_mark_stack, sizeof(Scheme_Object *)*b_mark_cnt); + b_mark_stack = naya; + } + b_mark_stack[b_mark_cnt++] = bcur_mark; + } + } + + /* Done if both reached the end: */ + if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) { + EXPLAIN(fprintf(stderr, " %d vs. %d marks\n", a_mark_cnt, b_mark_cnt)); + if (a_mark_cnt == b_mark_cnt) { + while (a_mark_cnt--) { + if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt])) + return 0; + } + return used_barrier + 1; + } else + return 0; + } + } +} + +static int includes_mark(Scheme_Object *wraps, Scheme_Object *mark) +/* Checks for positive or negative (certificate-only) mark. + FIXME: canceling marks are detected only when they're immediately + canceling (i.e., no canceled marks in between). */ +{ + WRAP_POS awl; + Scheme_Object *acur_mark; + + WRAP_POS_INIT(awl, wraps); + + while (1) { + /* Skip over renames and cancelled marks: */ + acur_mark = NULL; + while (1) { + if (WRAP_POS_END_P(awl)) + break; + if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) { + if (acur_mark) { + if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { + acur_mark = NULL; + WRAP_POS_INC(awl); + } else + break; + } else { + acur_mark = WRAP_POS_FIRST(awl); + WRAP_POS_INC(awl); + } + } else { + WRAP_POS_INC(awl); + } + } + + /* Same mark? */ + if (SAME_OBJ(acur_mark, mark)) + return 1; + + if (WRAP_POS_END_P(awl)) + return 0; + } +} + +static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) +/* Adds both positive and negative marks to marks table. This may add too many + marks, because it detects only immediately canceling marks. */ +{ + WRAP_POS awl; + Scheme_Object *acur_mark; + + WRAP_POS_INIT(awl, wraps); + + while (1) { + /* Skip over renames and cancelled marks: */ + acur_mark = NULL; + while (1) { + if (WRAP_POS_END_P(awl)) + break; + if (SCHEME_NUMBERP(WRAP_POS_FIRST(awl))) { + if (acur_mark) { + if (SAME_OBJ(acur_mark, WRAP_POS_FIRST(awl))) { + acur_mark = NULL; + WRAP_POS_INC(awl); + } else + break; + } else { + acur_mark = WRAP_POS_FIRST(awl); + WRAP_POS_INC(awl); + } + } else { + WRAP_POS_INC(awl); + } + } + + if (acur_mark) + scheme_hash_set(marks, acur_mark, scheme_true); + else + return; + } +} + +static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth, + int *_skipped) +{ + int l1, l2; + Scheme_Object *m1, *m2; + + p = SCHEME_CDR(p); /* skip modidx */ + p = SCHEME_CDR(p); /* skip phase_export */ + if (SCHEME_PAIRP(p)) { + /* has marks */ + int skip = 0; + + EXPLAIN(fprintf(stderr, "%d has marks\n", depth)); + + m1 = SCHEME_CAR(p); + if (*marks_cache) + m2 = *marks_cache; + else { + EXPLAIN(fprintf(stderr, "%d extract marks\n", depth)); + m2 = scheme_stx_extract_marks(orig_id); + *marks_cache = m2; + } + + l1 = scheme_list_length(m1); + l2 = scheme_list_length(m2); + + if (l2 < l1) return -1; /* no match */ + + while (l2 > l1) { + m2 = SCHEME_CDR(m2); + l2--; + skip++; + } + + if (scheme_equal(m1, m2)) { + if (_skipped ) *_skipped = skip; + return l1; /* matches */ + } else + return -1; /* no match */ + } else { + if (_skipped) *_skipped = -1; + return 0; /* match empty mark set */ + } +} + + +void scheme_populate_pt_ht(Scheme_Module_Phase_Exports * pt) { + if (!pt->ht) { + /* Lookup table (which is created lazily) not yet created, so do that now... */ + Scheme_Hash_Table *ht; + int i; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + for (i = pt->num_provides; i--; ) { + scheme_hash_set(ht, pt->provides[i], scheme_make_integer(i)); + } + pt->ht = ht; + } +} + +static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, + Scheme_Object *glob_id, Scheme_Object *orig_id, + Scheme_Object **get_names, int get_orig_name, + int depth, + int *_skipped) +{ + Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; + Scheme_Module_Phase_Exports *pt; + int i, phase, best_match_len = -1, skip = 0; + Scheme_Object *marks_cache = NULL; + + for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { + pt = (Scheme_Module_Phase_Exports *)SCHEME_CADR(SCHEME_CAR(pr)); + + EXPLAIN(fprintf(stderr, "%d pes table %s\n", depth, + pt->src_modidx + ? scheme_write_to_string(scheme_module_resolve(pt->src_modidx, 0), NULL) + : "?")); + + if (!pt->ht) { + /* Lookup table (which is created lazily) not yet created, so do that now... */ + EXPLAIN(fprintf(stderr, "%d {create lookup}\n", depth)); + scheme_populate_pt_ht(pt); + } + + pos = scheme_hash_get(pt->ht, glob_id); + if (pos) { + /* Found it, maybe. Check marks. */ + int mark_len; + EXPLAIN(fprintf(stderr, "%d found %p\n", depth, pos)); + mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip); + if (mark_len > best_match_len) { + /* Marks match and improve on previously found match. Build suitable rename: */ + best_match_len = mark_len; + if (_skipped) *_skipped = skip; + + idx = SCHEME_CAR(SCHEME_CAR(pr)); + + i = SCHEME_INT_VAL(pos); + + if (get_orig_name) + best_match = pt->provide_src_names[i]; + else { + if (pt->provide_srcs) + src = pt->provide_srcs[i]; + else + src = scheme_false; + + if (get_names) { + /* If module bound, result is module idx, and get_names[0] is set to source name, + get_names[1] is set to the nominal source module, get_names[2] is set to + the nominal source module's export, get_names[3] is set to the phase of + the source definition, get_names[4] is set to the module import phase index, + and get_names[5] is set to the nominal export phase */ + + if (pt->provide_src_phases) + phase = pt->provide_src_phases[i]; + else + phase = 0; + + EXPLAIN(fprintf(stderr, "%d srcname %s\n", depth, SCHEME_SYM_VAL(pt->provide_src_names[i]))); + get_names[0] = pt->provide_src_names[i]; + get_names[1] = idx; + get_names[2] = glob_id; + get_names[3] = scheme_make_integer(phase); + get_names[4] = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(pr))); + if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */ + get_names[4] = SCHEME_CDR(get_names[4]); + get_names[5] = pt->phase_index; + get_names[6] = (pt->provide_insps ? pt->provide_insps[i] : NULL); + } + + if (SCHEME_FALSEP(src)) { + src = idx; + } else { + src = scheme_modidx_shift(src, pt->src_modidx, idx); + } + + best_match = src; + } + } + } + } + + return best_match; +} + +static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object *phase) +{ + if (SAME_OBJ(phase, scheme_make_integer(0))) + return mrns->rt; + else if (SAME_OBJ(phase, scheme_make_integer(1))) + return mrns->et; + else if (mrns->other_phases) + return (Module_Renames *)scheme_hash_get(mrns->other_phases, phase); + else + return NULL; +} + +static int nonempty_rib(Scheme_Lexical_Rib *rib) +{ + rib = rib->next; + + while (rib) { + if (SCHEME_RENAME_LEN(rib->rename)) + return 1; + rib = rib->next; + } + + return 0; +} + +static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + if (!skip_ribs) + return 0; + + if (scheme_hash_tree_get((Scheme_Hash_Tree *)skip_ribs, timestamp)) + return 1; + + return 0; +} + +static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + if (in_skip_set(timestamp, skip_ribs)) + return skip_ribs; + + if (!skip_ribs) + skip_ribs = (Scheme_Object *)scheme_make_hash_tree(1); + + skip_ribs = (Scheme_Object *)scheme_hash_tree_set((Scheme_Hash_Tree *)skip_ribs, timestamp, scheme_true); + + { + Scheme_Bucket *b; + scheme_start_atomic(); + b = scheme_bucket_from_table(interned_skip_ribs, (const char *)skip_ribs); + scheme_end_atomic_no_swap(); + if (!b->val) + b->val = scheme_true; + + skip_ribs = (Scheme_Object *)HT_EXTRACT_WEAK(b->key); + } + + return skip_ribs; +} + +XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b) +{ + return SAME_OBJ(a, b); +} + +XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs) +{ + Scheme_Object *p; + + if (SCHEME_PAIRP(other_env)) { + /* paired with free-id=? rename */ + other_env = SCHEME_CAR(other_env); + } + + if (SCHEME_MPAIRP(other_env)) { + other_env = SCHEME_CAR(other_env); + if (!other_env) + return scheme_void; + } + + if (SCHEME_RPAIRP(other_env)) { + while (other_env) { + p = SCHEME_CAR(other_env); + if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) { + return SCHEME_CDR(p); + } + other_env = SCHEME_CDR(other_env); + } + return scheme_void; + } else if (!skip_ribs) + return other_env; + else + return scheme_void; +} + +static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs, + int depends_on_unsealed_rib) +{ + Scheme_Object *in_mpair = NULL; + Scheme_Object *free_id_rename = NULL; + + if (SCHEME_PAIRP(orig)) { + free_id_rename = SCHEME_CDR(orig); + orig = SCHEME_CAR(orig); + } + + if (SCHEME_MPAIRP(orig)) { + in_mpair = orig; + orig = SCHEME_CAR(orig); + if (!depends_on_unsealed_rib && !orig) { + /* no longer depends on unsealed rib: */ + in_mpair = NULL; + orig = scheme_void; + } else { + /* (some) still depends on unsealed rib: */ + if (!orig) { + /* re-register in list of dependencies */ + SCHEME_CDR(in_mpair) = unsealed_dependencies; + unsealed_dependencies = in_mpair; + orig = scheme_void; + } + } + } else if (depends_on_unsealed_rib) { + /* register dependency: */ + in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies); + unsealed_dependencies = in_mpair; + } + + if (SCHEME_VOIDP(orig) && !skip_ribs) { + orig = other_env; + } else { + if (!SCHEME_RPAIRP(orig)) + orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL); + + orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig); + } + + if (in_mpair) { + SCHEME_CAR(in_mpair) = orig; + orig = in_mpair; + } + + if (free_id_rename) { + orig = CONS(orig, free_id_rename); + } + + return orig; +} + +static void extract_lex_range(Scheme_Object *rename, Scheme_Object *a, int *_istart, int *_iend) +{ + int istart, iend, c; + + c = SCHEME_RENAME_LEN(rename); + + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { + void *pos; + pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), a); + if (pos) { + istart = SCHEME_INT_VAL(pos); + if (istart < 0) { + /* -1 indicates multiple slots matching this name. */ + istart = 0; + iend = c; + } else + iend = istart + 1; + } else { + istart = 0; + iend = 0; + } + } else { + istart = 0; + iend = c; + } + + *_istart = istart; + *_iend = iend; +} + +/* This needs to be a multiple of 4: */ +#define QUICK_STACK_SIZE 16 + +/* Although resolve_env may call itself recursively, the recursion + depth is bounded (by the fact that modules can't be nested, + etc.). */ + +static Scheme_Object *resolve_env(WRAP_POS *_wraps, + Scheme_Object *a, Scheme_Object *orig_phase, + int w_mod, Scheme_Object **get_names, + Scheme_Object *skip_ribs, int *_binding_marks_skipped, + int *_depends_on_unsealed_rib, int depth, + Scheme_Hash_Table *free_id_recur) +/* Module binding ignored if w_mod is 0. + If module bound, result is module idx, and get_names[0] is set to source name, + get_names[1] is set to the nominal source module, get_names[2] is set to + the nominal source module's export, get_names[3] is set to the phase of + the source definition, and get_names[4] is set to the nominal import phase index, + and get_names[5] is set to the nominal export phase; get_names[6] is set to + an inspector/pair if one applies for a re-export of a protected or unexported, NULL or + #f otherwise. + If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined; + get_names[1] is set if a free-id=? rename provides a different name for the bindig. + If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1] + is set if a free-id=? rename provides a different name. */ +{ + WRAP_POS wraps; + Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; + Scheme_Object *mresult = scheme_false, *mresult_insp; + Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; + Scheme_Object *rename_stack[QUICK_STACK_SIZE], *rib_delim = scheme_false; + int stack_pos = 0, no_lexical = 0; + int is_in_module = 0, skip_other_mods = 0, floating_checked = 0; + Scheme_Lexical_Rib *rib = NULL, *did_rib = NULL; + Scheme_Object *phase = orig_phase; + Scheme_Object *bdg = NULL, *floating = NULL; + Scheme_Hash_Table *export_registry = NULL; + int mresult_skipped = -1; + int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0; + + EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), + scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); + + if (_wraps) { + WRAP_POS_COPY(wraps, *_wraps); + WRAP_POS_INC(wraps); + } else + WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); + + while (1) { + if (WRAP_POS_END_P(wraps)) { + /* See rename case for info on rename_stack: */ + Scheme_Object *result, *result_free_rename, *key, *rd; + int did_lexical = 0; + + EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); + + result = scheme_false; + result_free_rename = scheme_false; + rib_delim = scheme_null; + while (!SCHEME_NULLP(o_rename_stack)) { + key = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[0]; + if (SAME_OBJ(key, result)) { + EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); + did_lexical = 1; + rd = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[3]; + if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { + /* not a match, due to rib delimiter */ + } else { + result = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[1]; + result_free_rename = SCHEME_VEC_ELS(SCHEME_CAR(o_rename_stack))[2]; + rib_delim = rd; + } + } else { + EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); + if (SAME_OBJ(key, scheme_true)) { + /* marks a module-level renaming that overrides lexical renaming */ + did_lexical = 0; + } + } + o_rename_stack = SCHEME_CDR(o_rename_stack); + } + while (stack_pos) { + key = rename_stack[stack_pos - 1]; + if (SAME_OBJ(key, result)) { + EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); + rd = rename_stack[stack_pos - 4]; + if (SCHEME_TRUEP(rd) && !SAME_OBJ(rd, rib_delim) && is_in_rib_delim(result, rd)) { + /* not a match, due to rib delimiter */ + } else { + result = rename_stack[stack_pos - 2]; + result_free_rename = rename_stack[stack_pos - 3]; + rib_delim = rd; + did_lexical = 1; + } + } else { + EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); + if (SAME_OBJ(key, scheme_true)) { + /* marks a module-level renaming that overrides lexical renaming */ + did_lexical = 0; + } + } + stack_pos -= 4; + } + if (!did_lexical) { + result = mresult; + if (_binding_marks_skipped) + *_binding_marks_skipped = mresult_skipped; + if (mresult_depends_unsealed) + depends_on_unsealed_rib = 1; + } else { + if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) { + Scheme_Object *orig; + int rib_dep = 0; + orig = result_free_rename; + result_free_rename = SCHEME_VEC_ELS(orig)[0]; + if (SCHEME_PAIRP(result_free_rename) && SCHEME_STXP(SCHEME_CAR(result_free_rename))) { + phase = SCHEME_CDR(result_free_rename); + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(orig)[1])) + phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]); + if (get_names) + get_names[1] = NULL; + result = SCHEME_CAR(result_free_rename); + if (!scheme_hash_get(free_id_recur, result)) { + scheme_hash_set(free_id_recur, result, scheme_true); + result = resolve_env(NULL, result, phase, + w_mod, get_names, + NULL, _binding_marks_skipped, + &rib_dep, depth + 1, free_id_recur); + } + if (get_names && !get_names[1]) + if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) + get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); + } else if (SCHEME_PAIRP(result_free_rename) && SCHEME_SYMBOLP(SCHEME_CDR(result_free_rename))) { + if (get_names) + get_names[1] = SCHEME_CAR(result_free_rename); + result = SCHEME_CDR(result_free_rename); + if (get_names) + get_names[0] = scheme_undefined; + } else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) { + result = SCHEME_VEC_ELS(result_free_rename)[0]; + if (get_names) { + get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1]; + get_names[1] = SCHEME_VEC_ELS(result_free_rename)[2]; + get_names[2] = SCHEME_VEC_ELS(result_free_rename)[3]; + get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4]; + get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5]; + get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6]; + get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7]; + } + } else { + if (get_names) + get_names[1] = SCHEME_CAR(result_free_rename); + result = scheme_false; + } + if (rib_dep) + depends_on_unsealed_rib = 1; + if (SAME_TYPE(SCHEME_TYPE(result), scheme_module_index_type)) + result = scheme_modidx_shift(result, SCHEME_VEC_ELS(orig)[2], SCHEME_VEC_ELS(orig)[3]); + } else { + if (get_names) { + get_names[0] = scheme_undefined; + get_names[1] = NULL; + } + } + } + + if (_depends_on_unsealed_rib) + *_depends_on_unsealed_rib = depends_on_unsealed_rib; + + EXPLAIN(fprintf(stderr, "%d Result: %s\n", depth, scheme_write_to_string(result, 0))); + + return result; + } else if ((SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) + || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) + && w_mod) { + /* Module rename: */ + Module_Renames *mrn; + int skipped; + + EXPLAIN(fprintf(stderr, "%d Rename/set\n", depth)); + + if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { + mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); + } else { + /* Extract the relevant phase, if available */ + Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps); + + if (mrns->kind != mzMOD_RENAME_TOPLEVEL) + is_in_module = 1; + + mrn = extract_renames(mrns, phase); + } + + if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) + && !skip_other_mods) { + if (mrn->kind != mzMOD_RENAME_TOPLEVEL) + is_in_module = 1; + + if (same_phase(phase, mrn->phase)) { + Scheme_Object *rename, *nominal = NULL, *glob_id; + int get_names_done; + + EXPLAIN(fprintf(stderr, "%d use rename %p %d\n", depth, mrn->phase, mrn->kind)); + + if (mrn->needs_unmarshal) { + EXPLAIN(fprintf(stderr, "%d {unmarshal}\n", depth)); + unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry); + } + + if (mrn->marked_names) { + /* Resolve based on rest of wraps: */ + EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); + if (!bdg) { + EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL); + if (SCHEME_FALSEP(bdg)) { + if (!floating_checked) { + floating = check_floating_id(a); + floating_checked = 1; + } + bdg = floating; + } + } + /* Remap id based on marks and rest-of-wraps resolution: */ + glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped); + + if (SCHEME_TRUEP(bdg) + && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { + /* Even if this module doesn't match, the lex-renamed id + has been top-level bound in its scope, so ignore all + lexical renamings. (If the id was further renamed, then + the further renaming would show up in bdg, and bdg wouldn't + have matched in marked_names.) */ + no_lexical = 1; + stack_pos = 0; + o_rename_stack = scheme_null; + } + } else { + skipped = -1; + glob_id = SCHEME_STX_VAL(a); + } + + EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); + + if (free_id_recur && mrn->free_id_renames) { + rename = scheme_hash_get(mrn->free_id_renames, glob_id); + if (rename && SCHEME_STXP(rename)) { + int sealed; + rename = extract_module_free_id_binding((Scheme_Object *)mrn, + glob_id, + rename, + &sealed, + free_id_recur); + if (!sealed) + mresult_depends_unsealed = 1; + } + } else + rename = NULL; + if (!rename) + rename = scheme_hash_get(mrn->ht, glob_id); + if (!rename && mrn->nomarshal_ht) + rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); + get_names_done = 0; + if (!rename) { + EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); + rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth, &skipped); + if (rename) + get_names_done = 1; + } + + EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename)); + + if (rename) { + if (mrn->sealed < STX_SEAL_BOUND) + mresult_depends_unsealed = 1; + + if (mrn->kind == mzMOD_RENAME_MARKED) { + /* One job of a mzMOD_RENAME_MARKED renamer is to replace any + binding that might have come from the identifier in its source + module, instead of the module where it was eventually bound + (after being introduced by a macro in the source module). */ + skip_other_mods = 1; + } + + /* match; set mresult, which is used in the case of no lexical capture: */ + mresult_skipped = skipped; + + mresult_insp = NULL; + + if (SCHEME_BOXP(rename)) { + /* This should only happen for mappings from free_id_renames */ + mresult = SCHEME_BOX_VAL(rename); + if (get_names) { + if (SCHEME_FALSEP(SCHEME_CDR(mresult))) + get_names[0] = NULL; + else + get_names[0] = scheme_undefined; + get_names[1] = SCHEME_CAR(mresult); + } + mresult = SCHEME_CDR(mresult); + } else { + if (SCHEME_PAIRP(rename)) { + mresult = SCHEME_CAR(rename); + if (is_rename_inspector_info(mresult)) { + mresult_insp = mresult; + rename = SCHEME_CDR(rename); + mresult = SCHEME_CAR(rename); + } + } else + mresult = rename; + + if (modidx_shift_from) + mresult = scheme_modidx_shift(mresult, + modidx_shift_from, + modidx_shift_to); + + if (get_names) { + int no_shift = 0; + + if (!get_names_done) { + if (SCHEME_PAIRP(rename)) { + if (nom_mod_p(rename)) { + /* (cons modidx nominal_modidx) case */ + get_names[0] = glob_id; + get_names[1] = SCHEME_CDR(rename); + get_names[2] = get_names[0]; + } else { + rename = SCHEME_CDR(rename); + if (SCHEME_PAIRP(rename)) { + /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ + if (SCHEME_INTP(SCHEME_CAR(rename)) + || SCHEME_FALSEP(SCHEME_CAR(rename))) { + get_names[3] = SCHEME_CAR(rename); + rename = SCHEME_CDR(rename); + } + get_names[0] = SCHEME_CAR(rename); + get_names[1] = SCHEME_CADR(rename); + if (SCHEME_PAIRP(get_names[1])) { + get_names[4] = SCHEME_CDR(get_names[1]); + get_names[1] = SCHEME_CAR(get_names[1]); + if (SCHEME_PAIRP(get_names[4])) { + get_names[5] = SCHEME_CDR(get_names[4]); + get_names[4] = SCHEME_CAR(get_names[4]); + } else { + get_names[5] = get_names[3]; + } + } + get_names[2] = SCHEME_CDDR(rename); + } else { + /* (cons modidx exportname) case */ + get_names[0] = rename; + get_names[2] = NULL; /* finish below */ + } + } + } else { + get_names[0] = glob_id; + get_names[2] = NULL; /* finish below */ + } + + if (!get_names[2]) { + get_names[2] = get_names[0]; + if (nominal) + get_names[1] = nominal; + else { + no_shift = 1; + get_names[1] = mresult; + } + } + if (!get_names[4]) { + GC_CAN_IGNORE Scheme_Object *pi; + pi = phase_to_index(mrn->phase); + get_names[4] = pi; + } + if (!get_names[5]) { + get_names[5] = get_names[3]; + } + get_names[6] = mresult_insp; + } + + if (modidx_shift_from && !no_shift) { + Scheme_Object *nom; + nom = get_names[1]; + nom = scheme_modidx_shift(nom, + modidx_shift_from, + modidx_shift_to); + get_names[1] = nom; + } + } + } + } else { + if (mrn->sealed < STX_SEAL_ALL) + mresult_depends_unsealed = 1; + mresult = scheme_false; + mresult_skipped = -1; + if (get_names) + get_names[0] = NULL; + } + } + } + } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps)) && w_mod) { + /* Phase shift */ + Scheme_Object *vec, *n, *dest, *src; + + EXPLAIN(fprintf(stderr, "%d phase shift\n", depth)); + + vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); + n = SCHEME_VEC_ELS(vec)[0]; + if (SCHEME_TRUEP(phase)) + phase = scheme_bin_minus(phase, n); + + src = SCHEME_VEC_ELS(vec)[1]; + dest = SCHEME_VEC_ELS(vec)[2]; + + /* If src is #f, shift is just for phase; no redirection */ + + if (!SCHEME_FALSEP(src)) { + if (!modidx_shift_to) { + modidx_shift_to = dest; + } else if (!SAME_OBJ(modidx_shift_from, dest)) { + modidx_shift_to = scheme_modidx_shift(dest, + modidx_shift_from, + modidx_shift_to); + } + + modidx_shift_from = src; + } + + { + Scheme_Object *er; + er = SCHEME_VEC_ELS(vec)[3]; + if (SCHEME_TRUEP(er)) + export_registry = (Scheme_Hash_Table *)er; + } + } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) + && !no_lexical)) { + /* Lexical rename: */ + Scheme_Object *rename, *renamed; + int ri, c, istart, iend; + Scheme_Lexical_Rib *is_rib; + + if (rib) { + rename = rib->rename; + is_rib = rib; + rib = rib->next; + } else { + rename = WRAP_POS_FIRST(wraps); + is_rib = NULL; + did_rib = NULL; + } + + EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0, + SCHEME_VEC_SIZE(rename), + SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "", + SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash")); + + c = SCHEME_RENAME_LEN(rename); + + /* Get index from hash table, if there is one: */ + extract_lex_range(rename, SCHEME_STX_VAL(a), &istart, &iend); + + for (ri = istart; ri < iend; ri++) { + renamed = SCHEME_VEC_ELS(rename)[2+ri]; + if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { + int same; + + { + Scheme_Object *other_env, *envname, *free_id_rename; + + if (SCHEME_SYMBOLP(renamed)) { + /* Simplified table */ + other_env = scheme_false; + envname = SCHEME_VEC_ELS(rename)[2+c+ri]; + if (SCHEME_PAIRP(envname)) { + free_id_rename = SCHEME_CDR(envname); + envname = SCHEME_CAR(envname); + } else + free_id_rename = scheme_void; + same = 1; + no_lexical = 1; /* simplified table always has final result */ + EXPLAIN(fprintf(stderr, "%d Targes %s <- %s %p\n", depth, + scheme_write_to_string(envname, 0), + scheme_write_to_string(other_env, 0), + free_id_rename)); + } else { + envname = SCHEME_VEC_ELS(rename)[0]; + other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; + if (SCHEME_PAIRP(other_env)) + free_id_rename = SCHEME_CDR(other_env); + else + free_id_rename = scheme_void; + other_env = filter_cached_env(other_env, recur_skip_ribs); + + if (SCHEME_VOIDP(other_env)) { + int rib_dep = 0; + SCHEME_USE_FUEL(1); + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL); + { + Scheme_Object *e; + e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, + (is_rib && !(*is_rib->sealed)) || rib_dep); + SCHEME_VEC_ELS(rename)[2+c+ri] = e; + } + if (rib_dep) + depends_on_unsealed_rib = 1; + SCHEME_USE_FUEL(1); + } + + EXPLAIN(fprintf(stderr, "%d Target %s <- %s (%d)\n", depth, + scheme_write_to_string(envname, 0), + scheme_write_to_string(other_env, 0), + nom_mod_p(rename))); + + { + WRAP_POS w2; + WRAP_POS_INIT(w2, ((Scheme_Stx *)renamed)->wraps); + same = same_marks(&w2, &wraps, other_env); + if (!same) + EXPLAIN(fprintf(stderr, "%d Different marks\n", depth)); + } + } + + if (same) { + /* If it turns out that we're going to return + other_env, then return envname instead. + It's tempting to try to compare envname to the + top element of the stack and combine the two + mappings, but the intermediate name may be needed + (for other_env values that don't come from this stack). */ + if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) { + /* Need to remember phase ad shifts for free-id=? rename: */ + Scheme_Object *vec; + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = free_id_rename; + SCHEME_VEC_ELS(vec)[1] = phase; + SCHEME_VEC_ELS(vec)[2] = modidx_shift_from; + SCHEME_VEC_ELS(vec)[3] = modidx_shift_to; + free_id_rename = vec; + } + if (stack_pos < QUICK_STACK_SIZE) { + rename_stack[stack_pos++] = rib_delim; + rename_stack[stack_pos++] = free_id_rename; + rename_stack[stack_pos++] = envname; + rename_stack[stack_pos++] = other_env; + } else { + Scheme_Object *vec; + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = other_env; + SCHEME_VEC_ELS(vec)[1] = envname; + SCHEME_VEC_ELS(vec)[2] = free_id_rename; + SCHEME_VEC_ELS(vec)[3] = rib_delim; + o_rename_stack = CONS(vec, o_rename_stack); + } + if (is_rib) { + /* skip future instances of the same rib; + used to skip the rest of the current rib, too, but + that's wrong in the case that the same symbolic + name with multiple binding contexts is re-bound + in a rib */ + skip_ribs = add_skip_set(is_rib->timestamp, skip_ribs); + } + } + + break; + } + } + } + } else if (SCHEME_RIBP(WRAP_POS_FIRST(wraps)) && !no_lexical) { + /* Lexical-rename rib. Splice in the names. */ + rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); + EXPLAIN(fprintf(stderr, "%d Rib: %p...\n", depth, rib)); + if (skip_ribs) { + if (in_skip_set(rib->timestamp, skip_ribs)) { + EXPLAIN(fprintf(stderr, "%d Skip rib\n", depth)); + rib = NULL; + } + } + if (rib) { + if (!*rib->sealed) + depends_on_unsealed_rib = 1; + if (nonempty_rib(rib)) { + if (SAME_OBJ(did_rib, rib)) { + EXPLAIN(fprintf(stderr, "%d Did rib\n", depth)); + rib = NULL; + } else { + recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); + did_rib = rib; + if (rib->mapped_names + && !SCHEME_INTP(rib->mapped_names) + && !scheme_hash_get((Scheme_Hash_Table *)rib->mapped_names, SCHEME_STX_VAL(a))) + rib = NULL; /* no need to check individual renames */ + else + rib = rib->next; /* First rib record has no rename */ + } + } else + rib = NULL; + } + } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(wraps))) { + rib_delim = WRAP_POS_FIRST(wraps); + if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) + rib_delim = scheme_false; + did_rib = NULL; + } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { + EXPLAIN(fprintf(stderr, "%d mark %p\n", depth, WRAP_POS_FIRST(wraps))); + did_rib = NULL; + } else if (SCHEME_HASHTP(WRAP_POS_FIRST(wraps))) { + Scheme_Hash_Table *ht = (Scheme_Hash_Table *)WRAP_POS_FIRST(wraps); + + EXPLAIN(fprintf(stderr, "%d forwarding table...\n", depth)); + + did_rib = NULL; + + if (!ht->count + /* Table isn't finished if 5 is mapped to a limit: */ + || scheme_hash_get(ht, scheme_make_integer(5))) { + fill_chain_cache(wraps.l); + } + + if (!scheme_hash_get(ht, SCHEME_STX_VAL(a))) { + EXPLAIN(fprintf(stderr, "%d forwarded\n", depth)); + set_wraps_to_skip(ht, &wraps); + + continue; /* <<<<< ------ */ + } + } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { + if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { + /* Doesn't match pruned-to sym; already produce #f */ + return scheme_false; + } + } + + if (!rib) + WRAP_POS_INC(wraps); + } +} + +static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, + Scheme_Hash_Table *free_id_recur) + /* Gets a module source name under the assumption that the identifier + is not lexically renamed. This is used as a quick pre-test for + free-identifier=?. We do have to look at lexical renames to check for + equivalences installed on detection of make-rename-transformer, but at least + we can normally cache the result. */ +{ + WRAP_POS wraps; + Scheme_Object *result, *result_from; + int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0; + int no_lexical = !free_id_recur; + Scheme_Object *phase = orig_phase; + Scheme_Object *bdg = NULL, *floating = NULL; + + if (!free_id_recur + && SAME_OBJ(phase, scheme_make_integer(0)) + && ((Scheme_Stx *)a)->u.modinfo_cache) + return ((Scheme_Stx *)a)->u.modinfo_cache; + + WRAP_POS_INIT(wraps, ((Scheme_Stx *)a)->wraps); + + result = NULL; + + while (1) { + if (WRAP_POS_END_P(wraps)) { + int can_cache = (sealed >= STX_SEAL_ALL); + + if (result) + can_cache = (sealed >= STX_SEAL_BOUND); /* If it becomes bound, it can't become unbound. */ + + if (!result) + result = SCHEME_STX_VAL(a); + + if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur) + ((Scheme_Stx *)a)->u.modinfo_cache = result; + + return result; + } else if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps)) + || SCHEME_RENAMES_SETP(WRAP_POS_FIRST(wraps))) { + Module_Renames *mrn; + + if (SCHEME_RENAMESP(WRAP_POS_FIRST(wraps))) { + mrn = (Module_Renames *)WRAP_POS_FIRST(wraps); + } else { + /* Extract the relevant phase, if available */ + Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(wraps); + + if (mrns->kind != mzMOD_RENAME_TOPLEVEL) + is_in_module = 1; + + if ((!is_in_module || (mrns->kind != mzMOD_RENAME_TOPLEVEL)) + && !skip_other_mods) { + if (mrns->sealed < sealed) + sealed = mrns->sealed; + } + + mrn = extract_renames(mrns, phase); + } + + if (mrn && (!is_in_module || (mrn->kind != mzMOD_RENAME_TOPLEVEL)) + && !skip_other_mods) { + if (mrn->kind != mzMOD_RENAME_TOPLEVEL) + is_in_module = 1; + + if (same_phase(phase, mrn->phase)) { + /* Module rename: */ + Scheme_Object *rename, *glob_id; + + if (mrn->sealed < sealed) + sealed = mrn->sealed; + + if (mrn->needs_unmarshal) { + /* Use resolve_env to trigger unmarshal, so that we + don't have to implement top/from shifts here: */ + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL); + } + + if (mrn->marked_names) { + /* Resolve based on rest of wraps: */ + if (!bdg) + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); + if (SCHEME_FALSEP(bdg)) { + if (!floating_checked) { + floating = check_floating_id(a); + floating_checked = 1; + } + bdg = floating; + } + /* Remap id based on marks and rest-of-wraps resolution: */ + glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL); + + if (SCHEME_TRUEP(bdg) + && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { + /* See "Even if this module doesn't match, the lex-renamed id" in resolve_env() */ + no_lexical = 1; + } + } else + glob_id = SCHEME_STX_VAL(a); + + if (free_id_recur && mrn->free_id_renames) { + rename = scheme_hash_get(mrn->free_id_renames, glob_id); + if (rename && SCHEME_STXP(rename)) { + int sealed; + rename = extract_module_free_id_binding((Scheme_Object *)mrn, + glob_id, + rename, + &sealed, + free_id_recur); + if (!sealed) + sealed = 0; + } + } else + rename = NULL; + if (!rename) + rename = scheme_hash_get(mrn->ht, glob_id); + if (!rename && mrn->nomarshal_ht) + rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); + + if (!rename) + result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL); + else { + /* match; set result: */ + if (mrn->kind == mzMOD_RENAME_MARKED) + skip_other_mods = 1; + if (SCHEME_BOXP(rename)) { + /* only happens with free_id_renames */ + rename = SCHEME_BOX_VAL(rename); + result = SCHEME_CAR(rename); + } else if (SCHEME_PAIRP(rename)) { + if (nom_mod_p(rename)) { + result = glob_id; + } else { + result = SCHEME_CDR(rename); + if (SCHEME_PAIRP(result)) + result = SCHEME_CAR(result); + } + } else + result = glob_id; + } + + result_from = WRAP_POS_FIRST(wraps); + } + } + } else if (SCHEME_BOXP(WRAP_POS_FIRST(wraps))) { + /* Phase shift */ + Scheme_Object *n, *vec; + vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(wraps)); + n = SCHEME_VEC_ELS(vec)[0]; + if (SCHEME_TRUEP(phase)) + phase = scheme_bin_minus(phase, n); + } else if (!no_lexical + && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) + || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) { + /* Lexical rename */ + Scheme_Object *rename, *renamed, *renames; + Scheme_Lexical_Rib *rib; + int ri, istart, iend; + + rename = WRAP_POS_FIRST(wraps); + if (SCHEME_RIBP(rename)) { + rib = (Scheme_Lexical_Rib *)rename; + if (rib->mapped_names + && !SCHEME_INTP(rib->mapped_names) + && !scheme_hash_get((Scheme_Hash_Table *)rib->mapped_names, SCHEME_STX_VAL(a))) + rib = NULL; /* no need to check individual renames */ + else + rib = rib->next; + rename = NULL; + } else { + rib = NULL; + if (SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[0])) { + /* No free-id=? renames here. */ + rename = NULL; + } + } + + do { + if (rib) { + if (!*rib->sealed) sealed = 0; + rename = rib->rename; + rib = rib->next; + } + + if (rename) { + int c = SCHEME_RENAME_LEN(rename); + + /* Get index from hash table, if there is one: */ + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { + void *pos; + pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a)); + if (pos) { + istart = SCHEME_INT_VAL(pos); + if (istart < 0) { + /* -1 indicates multiple slots matching this name. */ + istart = 0; + iend = c; + } else + iend = istart + 1; + } else { + istart = 0; + iend = 0; + } + } else { + istart = 0; + iend = c; + } + + for (ri = istart; ri < iend; ri++) { + renamed = SCHEME_VEC_ELS(rename)[2+ri]; + if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { + /* Check for free-id mapping: */ + renames = SCHEME_VEC_ELS(rename)[2 + ri + c]; + if (SCHEME_PAIRP(renames)) { + /* Has a relevant-looking free-id mapping. + Give up on the "fast" traversal. */ + Scheme_Object *modname, *names[7]; + int rib_dep; + + names[0] = NULL; + names[1] = NULL; + names[3] = scheme_make_integer(0); + names[4] = NULL; + names[5] = NULL; + names[6] = NULL; + + modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur); + if (rib_dep) + sealed = 0; + + if (!SCHEME_FALSEP(modname) + && !SAME_OBJ(names[0], scheme_undefined)) { + result = names[0]; + } else { + result = names[1]; /* can be NULL or alternate name */ + } + + WRAP_POS_INIT_END(wraps); + rib = NULL; + break; + } + } + } + } + } while (rib); + } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(wraps))) { + if (!is_member(SCHEME_STX_VAL(a), SCHEME_BOX_VAL(WRAP_POS_FIRST(wraps)))) { + /* Doesn't match pruned-to sym, so no binding */ + return SCHEME_STX_VAL(a); + } + } + + /* Keep looking: */ + if (!WRAP_POS_END_P(wraps)) + WRAP_POS_INC(wraps); + } +} + +int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym) +{ + Scheme_Object *bsym; + Scheme_Hash_Table *free_id_recur; + + if (!a || !b) + return (a == b); + + if (SCHEME_STXP(b)) { + if (!asym) + free_id_recur = make_recur_table(); + else + free_id_recur = NULL; + bsym = get_module_src_name(b, phase, free_id_recur); + if (!asym) + release_recur_table(free_id_recur); + } else + bsym = b; + if (!asym) { + if (SCHEME_STXP(a)) { + free_id_recur = make_recur_table(); + asym = get_module_src_name(a, phase, free_id_recur); + release_recur_table(free_id_recur); + } else + asym = a; + } + + /* Same name? */ + if (!SAME_OBJ(asym, bsym)) + return 0; + + if ((a == asym) || (b == bsym)) + return 1; + + free_id_recur = make_recur_table(); + a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); + release_recur_table(free_id_recur); + + free_id_recur = make_recur_table(); + b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); + release_recur_table(free_id_recur); + + if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) + a = scheme_module_resolve(a, 0); + if (SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) + b = scheme_module_resolve(b, 0); + + /* Same binding environment? */ + return SAME_OBJ(a, b); +} + +int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, intptr_t phase) +{ + return scheme_stx_module_eq2(a, b, scheme_make_integer(phase), NULL); +} + +Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase) +{ + if (SCHEME_STXP(a)) + return get_module_src_name(a, phase, NULL); + else + return a; +} + +Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, + Scheme_Object **a, Scheme_Object *phase, + Scheme_Object **nominal_modidx, /* how it was imported */ + Scheme_Object **nominal_name, /* imported as name */ + Scheme_Object **mod_phase, /* original defn phase level */ + Scheme_Object **src_phase_index, /* phase level of import from nominal modidx */ + Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */ + Scheme_Object **lex_env, + int *_sealed, + Scheme_Object **insp) + /* If module bound, result is module idx, and a is set to source name. + If lexically bound, result is scheme_undefined, a is unchanged, + and nominal_name is NULL or a free_id=? renamed id. + If neither, result is NULL, a is unchanged, and + and nominal_name is NULL or a free_id=? renamed id. */ +{ + if (SCHEME_STXP(*a)) { + Scheme_Object *modname, *names[7]; + int rib_dep; + + names[0] = NULL; + names[1] = NULL; + names[3] = scheme_make_integer(0); + names[4] = NULL; + names[5] = NULL; + names[6] = NULL; + + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur); + + if (_sealed) *_sealed = !rib_dep; + + if (names[0]) { + if (SAME_OBJ(names[0], scheme_undefined)) { + if (lex_env) + *lex_env = modname; + if (nominal_name) + *nominal_name = names[1]; + return scheme_undefined; + } else { + *a = names[0]; + if (nominal_modidx) + *nominal_modidx = names[1]; + if (nominal_name) + *nominal_name = names[2]; + if (mod_phase) + *mod_phase = names[3]; + if (src_phase_index) + *src_phase_index = names[4]; + if (nominal_src_phase) + *nominal_src_phase = names[5]; + if (insp) + *insp = names[6]; + return modname; + } + } else { + if (nominal_name) *nominal_name = names[1]; + return NULL; + } + } else { + if (nominal_name) *nominal_name = NULL; + if (_sealed) *_sealed = 1; + return NULL; + } +} + +int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) +{ + Scheme_Object *m1, *m2, *skips = NULL; + + while (SCHEME_PAIRP(skip_ribs)) { + skips = add_skip_set(((Scheme_Lexical_Rib *)SCHEME_CAR(skip_ribs))->timestamp, + skips); + skip_ribs = SCHEME_CDR(skip_ribs); + } + + m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL); + m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL); + + return !SAME_OBJ(m1, m2); +} + +Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) + /* Returns either false, a lexical-rename symbol, or void for "floating" */ +{ + if (SCHEME_STXP(a)) { + Scheme_Object *r; + + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL); + + if (SCHEME_FALSEP(r)) + r = check_floating_id(a); + + if (r) + return r; + } + return scheme_false; +} + +int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *uid, Scheme_Object *phase) + /* If uid is given, it's the environment for b. */ +{ + Scheme_Object *asym, *bsym, *ae, *be; + + if (!a || !b) + return (a == b); + + if (SCHEME_STXP(a)) + asym = SCHEME_STX_VAL(a); + else + asym = a; + if (SCHEME_STXP(b)) + bsym = SCHEME_STX_VAL(b); + else + bsym = b; + + /* Same name? */ + if (!SAME_OBJ(asym, bsym)) + return 0; + + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); + /* No need to module_resolve ae, because we ignored module renamings. */ + + if (uid) + be = uid; + else { + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); + /* No need to module_resolve be, because we ignored module renamings. */ + } + + /* Same binding environment? */ + if (!SAME_OBJ(ae, be)) + return 0; + + /* Same marks? (If not lexically bound, ignore mark barriers.) */ + if (!uid) { + WRAP_POS aw; + WRAP_POS bw; + WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); + WRAP_POS_INIT(bw, ((Scheme_Stx *)b)->wraps); + if (!same_marks(&aw, &bw, ae)) + return 0; + } + + return 1; +} + +int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase) +{ + return scheme_stx_env_bound_eq(a, b, NULL, phase); +} + +#if EXPLAIN_RESOLVE +Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) +{ + scheme_explain_resolves++; + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL); + --scheme_explain_resolves; + return a; +} +#endif + +Scheme_Object *scheme_stx_source_module(Scheme_Object *stx, int resolve, int source) +{ + /* Inspect the wraps to look for a self-modidx shift: */ + WRAP_POS w; + Scheme_Object *srcmod = scheme_false, *chain_from = NULL, *er; + Scheme_Hash_Table *export_registry = NULL; + + WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); + + while (!WRAP_POS_END_P(w)) { + if (SCHEME_BOXP(WRAP_POS_FIRST(w))) { + /* Phase shift: */ + Scheme_Object *vec, *dest, *src; + + vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(w)); + + src = SCHEME_VEC_ELS(vec)[1]; + dest = SCHEME_VEC_ELS(vec)[2]; + + /* If src is #f, shift is just for phase; no redirection */ + if (!SCHEME_FALSEP(src)) { + + if (!chain_from) { + srcmod = dest; + } else if (!SAME_OBJ(chain_from, dest)) { + srcmod = scheme_modidx_shift(dest, + chain_from, + srcmod); + } + + chain_from = src; + + if (!export_registry) { + er = SCHEME_VEC_ELS(vec)[3]; + if (SCHEME_TRUEP(er)) + export_registry = (Scheme_Hash_Table *)er; + } + } + } + + WRAP_POS_INC(w); + } + + if (SCHEME_TRUEP(srcmod)) { + if (resolve) { + srcmod = scheme_module_resolve(srcmod, 0); + if (export_registry && source) { + er = scheme_hash_get(export_registry, srcmod); + if (er) + srcmod = ((Scheme_Module_Exports *)er)->modsrc; + } + srcmod = SCHEME_PTR_VAL(srcmod); + } + } + + return srcmod; +} + +int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx) +{ + /* Inspect the wraps to look for a binding: */ + WRAP_POS w; + + WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); + + while (!WRAP_POS_END_P(w)) { + if (SCHEME_RENAMESP(WRAP_POS_FIRST(w))) { + /* Module rename. For simplicity, we look at all renames, even + if they're in the wrong phase, or for the wrong module, + etc. */ + Module_Renames *mrn = (Module_Renames *)WRAP_POS_FIRST(w); + + if (scheme_tl_id_is_sym_used(mrn->marked_names, sym)) + return 1; + } else if (SCHEME_RENAMES_SETP(WRAP_POS_FIRST(w))) { + Module_Renames_Set *mrns = (Module_Renames_Set *)WRAP_POS_FIRST(w); + int i; + + if (mrns->rt && scheme_tl_id_is_sym_used(mrns->rt->marked_names, sym)) + return 1; + if (mrns->et && scheme_tl_id_is_sym_used(mrns->et->marked_names, sym)) + return 1; + + if (mrns->other_phases) { + for (i = 0; i < mrns->other_phases->size; i++) { + if (mrns->other_phases->vals[i]) + scheme_tl_id_is_sym_used(((Module_Renames *)mrns->other_phases->vals[i])->marked_names, + sym); + } + } + } + WRAP_POS_INC(w); + } + + return 0; +} + +int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *id_certs, + Scheme_Object *than_id, Scheme_Object *than_id_certs) + /* There's a good chance that certs is an extension of than_certs. */ +{ + int i, j; + Scheme_Cert *certs, *t_certs; + Scheme_Hash_Table *ht, *t_ht = NULL; + + if ((!id_certs || SAME_OBJ(id_certs, than_id_certs)) + && !ACTIVE_CERTS((Scheme_Stx *)id)) + return 0; + + if (id_marks_ht) { + ht = id_marks_ht; + id_marks_ht = NULL; + } else + ht = scheme_make_hash_table(SCHEME_hash_ptr); + add_all_marks(((Scheme_Stx *)id)->wraps, ht); + + for (i = 0; i < 2; i++) { + if (i) + certs = ACTIVE_CERTS((Scheme_Stx *)id); + else + certs = (Scheme_Cert *)id_certs; + while (certs && !SAME_OBJ(certs, (Scheme_Cert *)than_id_certs)) { + if (scheme_hash_get(ht, certs->mark)) { + /* Found a relevant certificate in id */ + if (!t_ht) { + if (than_id_marks_ht) { + t_ht = than_id_marks_ht; + than_id_marks_ht = NULL; + } else + t_ht = scheme_make_hash_table(SCHEME_hash_ptr); + add_all_marks(((Scheme_Stx *)than_id)->wraps, t_ht); + } + if (scheme_hash_get(t_ht, certs->mark)) { + /* than_id has the same mark */ + for (j = 0; j < 2; j++) { + if (j) + t_certs = ACTIVE_CERTS((Scheme_Stx *)than_id); + else + t_certs = (Scheme_Cert *)than_id_certs; + while (t_certs) { + if (SAME_OBJ(t_certs->mark, certs->mark)) + break; + t_certs = t_certs->next; + } + if (t_certs) + break; + } + if (j == 2) { + scheme_reset_hash_table(ht, NULL); + id_marks_ht = ht; + scheme_reset_hash_table(t_ht, NULL); + than_id_marks_ht = t_ht; + return 1; + } + } + } + certs = certs->next; + } + } + + scheme_reset_hash_table(ht, NULL); + id_marks_ht = ht; + if (t_ht) { + scheme_reset_hash_table(t_ht, NULL); + than_id_marks_ht = t_ht; + } + + return 0; +} + +Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *a, Scheme_Object *relative_to, + Scheme_Object *uid) +{ + WRAP_POS aw; + WRAP_POS bw; + + WRAP_POS_INIT(aw, ((Scheme_Stx *)a)->wraps); + WRAP_POS_INIT(bw, ((Scheme_Stx *)relative_to)->wraps); + + if (!same_marks(&aw, &bw, scheme_false)) { + Scheme_Object *wraps = ((Scheme_Stx *)relative_to)->wraps; + if (uid) { + /* Add a rename record: */ + Scheme_Object *rn; + rn = scheme_make_rename(uid, 1); + scheme_set_rename(rn, 0, relative_to); + wraps = scheme_make_pair(rn, wraps); + } + + { + Scheme_Stx *stx = (Scheme_Stx *)a; + Scheme_Object *certs; + certs = stx->certs; + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); + stx->wraps = wraps; + stx->certs = certs; + a = (Scheme_Object *)stx; + } + } + + return a; +} + +/*========================================================================*/ +/* stx and lists */ +/*========================================================================*/ + +int scheme_stx_list_length(Scheme_Object *list) +{ + int len; + + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); + + len = 0; + while (!SCHEME_NULLP(list)) { + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); + if (SCHEME_PAIRP(list)) { + len++; + list = SCHEME_CDR(list); + } else { + if (!SCHEME_NULLP(list)) + len++; + break; + } + } + + return len; +} + +int scheme_stx_proper_list_length(Scheme_Object *list) +{ + int len; + Scheme_Object *turtle; + + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); + + len = 0; + turtle = list; + while (SCHEME_PAIRP(list)) { + len++; + + list = SCHEME_CDR(list); + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); + + if (!SCHEME_PAIRP(list)) + break; + len++; + list = SCHEME_CDR(list); + if (SCHEME_STXP(list)) + list = SCHEME_STX_VAL(list); + + if (SAME_OBJ(turtle, list)) + break; + + turtle = SCHEME_CDR(turtle); + if (SCHEME_STXP(turtle)) + turtle = SCHEME_STX_VAL(turtle); + + } + + if (SCHEME_NULLP(list)) + return len; + + return -1; +} + +#ifdef DO_STACK_CHECK +static Scheme_Object *flatten_syntax_list_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *l = (Scheme_Object *)p->ku.k.p1; + int *r = (int *)p->ku.k.p2; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + + return scheme_flatten_syntax_list(l, r); +} +#endif + +Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist) +{ + Scheme_Object *l = lst, *lflat, *first, *last; + + /* Check whether the list ends in a null: */ + while (SCHEME_PAIRP(l)) { + l = SCHEME_CDR(l); + } + + if (SCHEME_NULLP(l)) { + /* Yes. We're done: */ + if (islist) + *islist = 1; + return lst; + } + + if (islist) + *islist = 0; + + lflat = NULL; + + /* Is it a syntax object, possibly with a list? */ + if (SCHEME_STXP(l)) { + l = scheme_stx_content(l); + if (SCHEME_NULLP(l) || SCHEME_PAIRP(l)) { + int lislist; + + lflat = NULL; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + int *r; + + r = (int *)scheme_malloc_atomic(sizeof(int)); + + p->ku.k.p1 = (void *)l; + p->ku.k.p2 = (void *)r; + + lflat = scheme_handle_stack_overflow(flatten_syntax_list_k); + + lislist = *r; + } + } +#endif + + if (!lflat) + lflat = scheme_flatten_syntax_list(l, &lislist); + + if (!lislist) { + /* Not a list. Can't flatten this one. */ + return lst; + } + } else { + /* Not a syntax list. No chance of flattening. */ + return lst; + } + } else { + /* No. No chance of flattening, then. */ + return lst; + } + + /* Need to flatten, end with lflat */ + + if (islist) + *islist = 1; + + first = last = NULL; + for (l = lst; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) { + Scheme_Object *p; + p = scheme_make_pair(SCHEME_CAR(l), scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + } + + if (last) + SCHEME_CDR(last) = lflat; + else + first = lflat; + + return first; +} + +/*========================================================================*/ +/* wraps->datum */ +/*========================================================================*/ + +/* Used for marshaling syntax objects. Note that we build a reverse + list for wraps. (Unmarshaler will reverse it back.) + + The wraps->datum tools are also used to simplify syntax object (to + minimize the occupied space among a set of objects). */ + +#define EXPLAIN_SIMP 0 +#if EXPLAIN_SIMP +#define EXPLAIN_S(x) if (explain_simp) x +static int explain_simp = 0; +static void print_skips(Scheme_Object *skips) +{ + while (skips) { + fprintf(stderr, " skip %s\n", scheme_write_to_string(SCHEME_CAR(skips), NULL)); + skips = SCHEME_CDR(skips); + } +} +#else +#define EXPLAIN_S(x) /* empty */ +#endif + +static Scheme_Object *extract_free_id_info(Scheme_Object *id) +{ + Scheme_Object *bind; + Scheme_Object *nominal_modidx; + Scheme_Object *nominal_name, *nom2; + Scheme_Object *mod_phase; + Scheme_Object *src_phase_index; + Scheme_Object *nominal_src_phase; + Scheme_Object *lex_env = NULL; + Scheme_Object *vec, *phase, *insp; + Scheme_Hash_Table *free_id_recur; + + phase = SCHEME_CDR(id); + id = SCHEME_CAR(id); + + nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); + + free_id_recur = make_recur_table(); + bind = scheme_stx_module_name(free_id_recur, + &id, phase, &nominal_modidx, &nominal_name, + &mod_phase, &src_phase_index, &nominal_src_phase, + &lex_env, NULL, &insp); + release_recur_table(free_id_recur); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; + if (!nominal_name) + nominal_name = SCHEME_STX_VAL(id); + + if (!bind) + return CONS(nominal_name, scheme_false); + else if (SAME_OBJ(bind, scheme_undefined)) + return CONS(nominal_name, lex_env); + else { + vec = scheme_make_vector(8, NULL); + vec->type = scheme_free_id_info_type; + SCHEME_VEC_ELS(vec)[0] = bind; + SCHEME_VEC_ELS(vec)[1] = id; + SCHEME_VEC_ELS(vec)[2] = nominal_modidx; + SCHEME_VEC_ELS(vec)[3] = nominal_name; + SCHEME_VEC_ELS(vec)[4] = mod_phase; + SCHEME_VEC_ELS(vec)[5] = src_phase_index; + SCHEME_VEC_ELS(vec)[6] = nominal_src_phase; + SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false); + return vec; + } +} + +static int not_in_rename(Scheme_Object *constrain_to_syms, Scheme_Object *rename) +{ + int istart, iend, ri; + Scheme_Object *renamed, *s; + + while (SCHEME_PAIRP(constrain_to_syms)) { + + s = SCHEME_CAR(constrain_to_syms); + extract_lex_range(rename, s, &istart, &iend); + + for (ri = istart; ri < iend; ri++) { + renamed = SCHEME_VEC_ELS(rename)[2+ri]; + if (SAME_OBJ(renamed, s)) + return 0; + } + + constrain_to_syms = SCHEME_CDR(constrain_to_syms); + } + + return 1; +} + +static int not_in_rib(Scheme_Object *constrain_to_syms, Scheme_Lexical_Rib *rib) +{ + for (rib = rib->next; rib; rib = rib->next) { + if (!not_in_rename(constrain_to_syms, rib->rename)) + return 0; + } + return 1; +} + +#define EXPLAIN_R(x) /* empty */ + +static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache, + Scheme_Object *stx_datum) +{ + WRAP_POS w, prev, w2; + Scheme_Object *stack = scheme_null, *key, *old_key, *prec_ribs, *prev_prec_ribs; + Scheme_Object *ribs_stack = scheme_null, *rib_delim = scheme_false, *constrain_to_syms = NULL; + Scheme_Object *v, *v2, *v2l, *v2rdl, *stx, *name, *svl, *end_mutable = NULL, **v2_rib_delims = NULL, *svrdl; + Scheme_Lexical_Rib *did_rib = NULL; + Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; + int copy_on_write, no_rib_mutation = 1, rib_count = 0; + intptr_t size, vsize, psize, i, j, pos; + + /* Although it makes no sense to simplify the rename table itself, + we can simplify it in the context of a particular wrap suffix. + (But don't mutate the wrap list, because that will stomp on + tables that might be needed by a propoagation.) + + A lex_cache maps wrap starts within `w' to lists of simplified + tables. This helps avoid re-simplifying when the result is + clearly going to be the same. A lex_cache is read and modified by + this function, only. + + In addition to depending on the rest of the wraps, a resolved + binding can depend on preceding wraps due to rib skipping. For + now, simplifications that depend on preceding wraps are not + cached (though individual computed renamings are cached to save + space). + + The simplification stragegy mostly works inside out: since later + renames depend on earlier renames, we simplify the earlier ones + first, and then collapse to a flattened rename while working + outward. This also lets us track shared tails in some common + cases. + + A catch with the inside-out approach has to do with ribs (again). + Preceding ribs determine the recur_skip_ribs set, so we can + simply track that as we recur into the wraps initially to build + our worklist. However, whether we process a rib at all (on the + way out in the second pass) for a given id depends on whether any + preceding instance of the same rib (i.e., further out) matches + the symbol and marks. So, we have to compute that summary as we + go in. */ + + if (SCHEME_SYMBOLP(stx_datum)) { + /* Search for prunings */ + WRAP_POS_INIT(w, wraps); + old_key = NULL; + prec_ribs = NULL; + while (!WRAP_POS_END_P(w)) { + if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) + || SCHEME_RIBP(WRAP_POS_FIRST(w))) { + /* Lexical rename --- maybe an already-simplified point */ + key = WRAP_POS_KEY(w); + if (!SAME_OBJ(key, old_key)) { + v = scheme_hash_get(lex_cache, key); + if (v && SCHEME_HASHTP(v)) { + v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); + } else if (prec_ribs) + v = NULL; + } else + v = NULL; + old_key = key; + + if (v) { + /* Tables here are already simplified. */ + break; + } + + if (SCHEME_RIBP(WRAP_POS_FIRST(w))) { + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(w); + if (!nonempty_rib(rib)) + prec_ribs = add_skip_set(rib->timestamp, prec_ribs); + } + } else if (SCHEME_PRUNEP(WRAP_POS_FIRST(w))) { + v = SCHEME_BOX_VAL(WRAP_POS_FIRST(w)); + if (is_member(stx_datum, v)) { + if (!constrain_to_syms) + constrain_to_syms = v; + else { + v2 = scheme_null; + while (SCHEME_PAIRP(v)) { + if (is_member(SCHEME_CAR(v), constrain_to_syms)) + v2 = scheme_make_pair(SCHEME_CAR(v), v2); + v = SCHEME_CDR(v); + } + constrain_to_syms = v2; + } + } else + constrain_to_syms = scheme_null; + } + WRAP_POS_INC(w); + } + } + + WRAP_POS_INIT(w, wraps); + WRAP_POS_INIT_END(prev); + + old_key = NULL; + prec_ribs = NULL; + + v2l = scheme_null; + v2rdl = NULL; + + EXPLAIN_S(fprintf(stderr, "[in simplify]\n")); + + EXPLAIN_R(printf("Simplifying %p\n", lex_cache)); + + while (!WRAP_POS_END_P(w)) { + if (SCHEME_VECTORP(WRAP_POS_FIRST(w)) + || SCHEME_RIBP(WRAP_POS_FIRST(w))) { + /* Lexical rename */ + key = WRAP_POS_KEY(w); + EXPLAIN_R(printf(" key %p\n", key)); + if (!SAME_OBJ(key, old_key)) { + v = scheme_hash_get(lex_cache, key); + if (v && SCHEME_HASHTP(v)) { + v = scheme_hash_get((Scheme_Hash_Table *)v, prec_ribs ? prec_ribs : scheme_false); + } else if (prec_ribs) + v = NULL; + } else + v = NULL; + old_key = key; + prev_prec_ribs = prec_ribs; + prev_skip_ribs_ht = skip_ribs_ht; + + if (v) { + /* Tables here are already simplified. */ + v2l = v; /* build on simplify chain extracted from cache */ + end_mutable = v2l; + /* No non-simplified table can follow a simplified one */ + break; + } else { + int add = 0, skip_this = 0; + + v = WRAP_POS_FIRST(w); + if (SCHEME_RIBP(v)) { + /* A rib certainly isn't simplified yet. */ + Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; + no_rib_mutation = 0; + add = 1; + if (!*rib->sealed) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + if (SAME_OBJ(did_rib, rib) + || !nonempty_rib(rib) + || (constrain_to_syms && !not_in_rib(constrain_to_syms, rib))) { + skip_this = 1; + if (!nonempty_rib(rib)) + prec_ribs = add_skip_set(rib->timestamp, prec_ribs); + EXPLAIN_S(fprintf(stderr, " to skip %p=%s\n", rib, + scheme_write_to_string(rib->timestamp, NULL))); + } else { + rib_count++; + did_rib = rib; + prec_ribs = add_skip_set(rib->timestamp, prec_ribs); + + EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, + scheme_write_to_string(rib->timestamp, NULL))); + EXPLAIN_S(print_skips(prec_ribs)); + + copy_on_write = 1; + + EXPLAIN_R(printf(" rib %p\n", rib->timestamp)); + + /* Compute, per id, whether to skip later instances of rib: */ + for (rib = rib->next; rib; rib = rib->next) { + vsize = SCHEME_RENAME_LEN(rib->rename); + for (i = 0; i < vsize; i++) { + stx = SCHEME_VEC_ELS(rib->rename)[2+i]; + + EXPLAIN_S(fprintf(stderr, " skip? %s %p=%s %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL), + rib, + scheme_write_to_string(rib->timestamp, NULL), + scheme_write_to_string(SCHEME_VEC_ELS(rib->rename)[0], NULL))); + + /* already skipped? */ + if ((!constrain_to_syms || is_member(SCHEME_STX_VAL(stx), constrain_to_syms)) + && (!skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp)))) { + /* No. Should we skip? */ + Scheme_Object *other_env; + other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; + other_env = filter_cached_env(other_env, prec_ribs); + if (SCHEME_VOIDP(other_env)) { + int rib_dep; + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); + if (rib_dep) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + { + Scheme_Object *e; + e = extend_cached_env(SCHEME_VEC_ELS(rib->rename)[2+vsize+i], other_env, prec_ribs, 0); + SCHEME_VEC_ELS(rib->rename)[2+vsize+i] = e; + } + } + WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); + if (same_marks(&w2, &w, other_env)) { + /* yes, skip */ + EXPLAIN_S(fprintf(stderr, " skip! %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); + if (!skip_ribs_ht) + skip_ribs_ht = scheme_make_hash_table_equal(); + else if (copy_on_write) + skip_ribs_ht = scheme_clone_hash_table(skip_ribs_ht); + copy_on_write = 0; + scheme_hash_set(skip_ribs_ht, + scheme_make_pair(SCHEME_STX_VAL(stx), rib->timestamp), + scheme_true); + } + } else { + EXPLAIN_S(fprintf(stderr, " already skipped %s\n", + scheme_write_to_string(SCHEME_STX_VAL(stx), NULL))); + } + } + } + } + } else { + /* Need to simplify this vector? */ + if (SCHEME_VEC_SIZE(v) == 1) + v = SCHEME_VEC_ELS(v)[0]; + if ((SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ + && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2])) { + add = 1; + + if (constrain_to_syms) { + /* Maybe pruned so that we don't need to resolve: */ + if (not_in_rename(constrain_to_syms, v)) + skip_this = 1; + } + } + EXPLAIN_R(printf(" lex reset\n")); + did_rib = NULL; + } + + if (add) { + if (skip_this) { + ribs_stack = scheme_make_pair(scheme_false, ribs_stack); + } else { + ribs_stack = scheme_make_pair(scheme_make_pair(prec_ribs, + scheme_make_pair((Scheme_Object *)prev_skip_ribs_ht, + rib_delim)), + ribs_stack); + } + + /* Need to simplify, but do deepest first: */ + if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_VEC_ELS(SCHEME_CAR(stack))[0], key)) { + v = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(v)[0] = key; + SCHEME_VEC_ELS(v)[1] = prev_prec_ribs; + stack = CONS(v, stack); + } + } else { + /* This is already simplified. Remember it and stop, because + no non-simplified table can follow a simplified one. */ + WRAP_POS_COPY(prev, w); + break; + } + } + } else if (SCHEME_RIB_DELIMP(WRAP_POS_FIRST(w))) { + rib_delim = WRAP_POS_FIRST(w); + if (SCHEME_NULLP(SCHEME_BOX_VAL(rib_delim))) + rib_delim = scheme_false; + if (rib_count > 1) { + EXPLAIN_R(if (did_rib) printf(" reset delim %d\n", rib_count)); + did_rib = NULL; + } + rib_count = 0; + } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(w))) { + v = WRAP_POS_FIRST(w); + WRAP_POS_COPY(w2, w); + WRAP_POS_INC(w2); + if (!WRAP_POS_END_P(w2) && SAME_OBJ(v, WRAP_POS_FIRST(w2))) { + WRAP_POS_INC(w); + } else { + EXPLAIN_R(printf(" reset by mark\n")); + did_rib = NULL; + } + } else { + EXPLAIN_R(if (did_rib) printf(" reset %d\n", SCHEME_TYPE(WRAP_POS_FIRST(w)))); + did_rib = NULL; + } + + WRAP_POS_INC(w); + } + + EXPLAIN_R(printf(" ... phase2\n")); + + while (!SCHEME_NULLP(stack)) { + key = SCHEME_CAR(stack); + prev_prec_ribs = SCHEME_VEC_ELS(key)[1]; + key = SCHEME_VEC_ELS(key)[0]; + + WRAP_POS_REVINIT(w, key); + + while (!WRAP_POS_REVEND_P(w)) { + v = WRAP_POS_FIRST(w); + + if (SCHEME_RIBP(v) + || (SCHEME_VECTORP(v) + && (SCHEME_VEC_SIZE(v) > 2) /* a simplified vec can be empty */ + && !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[2]))) { + /* This is the place to simplify: */ + Scheme_Lexical_Rib *rib = NULL, *init_rib = NULL; + Scheme_Object *local_ribs; + int ii, vvsize, done_rib_pos = 0; + + rib_delim = scheme_false; + + if (SCHEME_FALSEP(SCHEME_CAR(ribs_stack))) { + EXPLAIN_S(fprintf(stderr, " skip rib %p=%s\n", v, + scheme_write_to_string(((Scheme_Lexical_Rib *)v)->timestamp, NULL))); + ribs_stack = SCHEME_CDR(ribs_stack); + vsize = 0; + local_ribs = NULL; + } else { + rib_delim = SCHEME_CAR(ribs_stack); + prec_ribs = SCHEME_CAR(rib_delim); + rib_delim = SCHEME_CDR(rib_delim); + skip_ribs_ht = (Scheme_Hash_Table *)SCHEME_CAR(rib_delim); + rib_delim = SCHEME_CDR(rib_delim); + ribs_stack = SCHEME_CDR(ribs_stack); + + if (SCHEME_RIBP(v)) { + init_rib = (Scheme_Lexical_Rib *)v; + EXPLAIN_S(fprintf(stderr, " up rib %p=%s\n", init_rib, + scheme_write_to_string(init_rib->timestamp, NULL))); + EXPLAIN_S(print_skips(prec_ribs)); + rib = init_rib->next; + vsize = 0; + local_ribs = NULL; + while (rib) { + /* We need to process the renamings in reverse order: */ + local_ribs = scheme_make_raw_pair((Scheme_Object *)rib, local_ribs); + + vsize += SCHEME_RENAME_LEN(rib->rename); + rib = rib->next; + } + if (local_ribs) { + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); + local_ribs = SCHEME_CDR(local_ribs); + } + } else { + vsize = SCHEME_RENAME_LEN(v); + local_ribs = NULL; + } + } + + /* Initial size; may shrink: */ + size = vsize; + + v2 = scheme_make_vector(2 + (2 * size), NULL); + v2_rib_delims = MALLOC_N(Scheme_Object *, size); + + pos = 0; /* counter for used slots */ + + /* Local vector (different from i when we have a rib) */ + ii = 0; + vvsize = vsize; + + for (i = 0; i < vsize; i++) { + if (rib) { + v = rib->rename; + vvsize = SCHEME_RENAME_LEN(v); + while (ii >= vvsize) { + ii = 0; + done_rib_pos = pos; + rib = (Scheme_Lexical_Rib *)SCHEME_CAR(local_ribs); + local_ribs = SCHEME_CDR(local_ribs); + v = rib->rename; + vvsize = SCHEME_RENAME_LEN(v); + } + } + stx = SCHEME_VEC_ELS(v)[2+ii]; + name = SCHEME_STX_VAL(stx); + SCHEME_VEC_ELS(v2)[2+pos] = name; + + if ((!constrain_to_syms || is_member(name, constrain_to_syms)) + && (!rib + || !skip_ribs_ht + || !scheme_hash_get(skip_ribs_ht, scheme_make_pair(name, rib->timestamp)))) { + /* Either this name is in prev, in which case the answer + must match this rename's target, or this rename's + answer applies. */ + Scheme_Object *ok = NULL, *ok_replace = NULL, **ok_replace_rd = NULL; + int ok_replace_index = 0, ok_replace_rd_index = 0; + Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env; + + if (rib) { + EXPLAIN_S(fprintf(stderr, " resolve %s %s (%d)\n", + scheme_write_to_string(name, NULL), + scheme_write_to_string(rib->timestamp, NULL), + done_rib_pos)); + } + + other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; + if (SCHEME_PAIRP(other_env)) + free_id_rename = extract_free_id_info(SCHEME_CDR(other_env)); + else + free_id_rename = NULL; + other_env = filter_cached_env(other_env, prec_ribs); + if (SCHEME_VOIDP(other_env)) { + int rib_dep; + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); + if (rib_dep) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } + if (!prec_ribs) { + if (free_id_rename) + ok = CONS(other_env, free_id_rename); + else + ok = other_env; + SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; + ok = NULL; + } else { + ok = extend_cached_env(SCHEME_VEC_ELS(v)[2+vvsize+ii], other_env, prec_ribs, 0); + SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; + ok = NULL; + } + } + + if (!WRAP_POS_END_P(prev) + || SCHEME_PAIRP(v2l)) { + WRAP_POS w3; + Scheme_Object *vp, **vrdp; + + /* Check marks (now that we have the correct barriers). */ + WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); + if (!same_marks(&w2, &w, other_env)) { + other_env = NULL; + } + + if (other_env) { + /* A simplified table needs to have the final answer, so + fold conversions from the rest of the wraps. In the case + of ribs, the "rest" can include earlier rib renamings. + Otherwise, check simplications accumulated in v2l (possibly from a + previously simplified tail in the same cache). Finally, + try prev (from a previously simplified tail in an earlier + round of simplifying). */ + int rib_found = 0; + if (done_rib_pos) { + for (j = 0; j < done_rib_pos; j++) { + if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) { + rib_found = 1; + prev_env = SCHEME_VEC_ELS(v2)[2+size+j]; + orig_prev_env = prev_env; + if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); + if (SAME_OBJ(prev_env, other_env)) { + if (SCHEME_FALSEP(rib_delim) + || SAME_OBJ(v2_rib_delims[j], rib_delim) + || !is_in_rib_delim(prev_env, rib_delim)) { + ok = SCHEME_VEC_ELS(v)[0]; + ok_replace = v2; + ok_replace_index = 2 + size + j; + ok_replace_rd = v2_rib_delims; + if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) + free_id_rename = SCHEME_CDR(orig_prev_env); + } + } else { + EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); + ok = NULL; + } + break; + } + } + } + if (!rib_found) { + int passed_mutable = 0; + WRAP_POS_COPY(w3, prev); + svl = v2l; + svrdl = v2rdl; + for (; SCHEME_PAIRP(svl) || !WRAP_POS_END_P(w3); ) { + if (SAME_OBJ(svl, end_mutable)) passed_mutable = 1; + if (SCHEME_PAIRP(svl)) { + vp = SCHEME_CAR(svl); + if (svrdl) + vrdp = (Scheme_Object **)SCHEME_CAR(svrdl); + else + vrdp = NULL; + } else { + vp = WRAP_POS_FIRST(w3); + vrdp = NULL; + } + if (SCHEME_VECTORP(vp)) { + psize = SCHEME_RENAME_LEN(vp); + for (j = 0; j < psize; j++) { + if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) { + prev_env = SCHEME_VEC_ELS(vp)[2+psize+j]; + orig_prev_env = prev_env; + if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); + if (SAME_OBJ(prev_env, other_env) + && (SCHEME_FALSEP(rib_delim) + || (vrdp && (SAME_OBJ(vrdp[j], rib_delim))) + || !is_in_rib_delim(prev_env, rib_delim))) { + ok = SCHEME_VEC_ELS(v)[0]; + if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) + free_id_rename = SCHEME_CDR(orig_prev_env); + } else { + EXPLAIN_S(fprintf(stderr, + " not matching deeper %s\n", + scheme_write_to_string(other_env, NULL))); + ok = NULL; + /* Alternate time/space tradeoff: could be + SCHEME_VEC_ELS(vp)[2+psize+j], + which is the value from prev */ + } + if (ok && SCHEME_PAIRP(svl) && !passed_mutable + && (SCHEME_FALSEP(rib_delim) || vrdp)) { + /* Can overwrite old map, instead + of adding a new one. */ + ok_replace = vp; + ok_replace_index = 2 + psize + j; + ok_replace_rd = vrdp; + ok_replace_rd_index = j; + } + break; + } + } + if (j < psize) + break; + } + if (SCHEME_PAIRP(svl)) { + svl = SCHEME_CDR(svl); + if (svrdl) svrdl = SCHEME_CDR(svrdl); + } else { + WRAP_POS_INC(w3); + } + } + if (WRAP_POS_END_P(w3) && SCHEME_NULLP(svl) && SCHEME_FALSEP(other_env)) + ok = SCHEME_VEC_ELS(v)[0]; + } + } else + ok = NULL; + } else { + if (!SCHEME_FALSEP(other_env)) { + EXPLAIN_S(fprintf(stderr, " not based on #f\n")); + ok = NULL; + } else { + WRAP_POS_INIT(w2, ((Scheme_Stx *)stx)->wraps); + if (same_marks(&w2, &w, scheme_false)) + ok = SCHEME_VEC_ELS(v)[0]; + else { + EXPLAIN_S(fprintf(stderr, " not matching marks\n")); + ok = NULL; + } + } + } + + if (ok) { + if (free_id_rename) + ok = CONS(ok, free_id_rename); + if (ok_replace) { + EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", + scheme_write_to_string(ok, NULL))); + SCHEME_VEC_ELS(ok_replace)[ok_replace_index] = ok; + ok_replace_rd[ok_replace_rd_index] = rib_delim; + } else { + EXPLAIN_S(fprintf(stderr, " add mapping %s\n", + scheme_write_to_string(ok, NULL))); + SCHEME_VEC_ELS(v2)[2+size+pos] = ok; + v2_rib_delims[pos] = rib_delim; + pos++; + } + } else { + EXPLAIN_S(fprintf(stderr, " no mapping %s\n", + scheme_write_to_string(name, NULL))); + } + } else { + EXPLAIN_S(fprintf(stderr, " skip %s %s %p\n", + scheme_write_to_string(name, NULL), + scheme_write_to_string(rib->timestamp, NULL), + rib)); + } + ii++; + } + + if (!pos) + v2 = empty_simplified; + else { + if (pos != size) { + /* Shrink simplified vector */ + v = v2; + v2 = scheme_make_vector(2 + (2 * pos), NULL); + for (i = 0; i < pos; i++) { + SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; + SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; + } + } + + SCHEME_VEC_ELS(v2)[0] = scheme_false; + for (i = 0; i < pos; i++) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v2)[2+pos+i])) + SCHEME_VEC_ELS(v2)[0] = scheme_true; + } + + SCHEME_VEC_ELS(v2)[1] = scheme_false; + maybe_install_rename_hash_table(v2); + + if (no_rib_mutation) { + /* Sometimes we generate the same simplified lex table, so + look for an equivalent one in the cache. */ + v = scheme_hash_get(lex_cache, scheme_true); + if (!v) { + v = (Scheme_Object *)scheme_make_hash_table_equal(); + scheme_hash_set(lex_cache, scheme_true, v); + } + svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); + if (svl) + v2 = svl; + else + scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); + } + } + + v2l = CONS(v2, v2l); + v2rdl = scheme_make_raw_pair((Scheme_Object *)v2_rib_delims, v2rdl); + } + + WRAP_POS_DEC(w); + } + + if (!constrain_to_syms) { + v = scheme_hash_get(lex_cache, key); + if (!v && !prev_prec_ribs) { + /* no dependency on ribs, so we can simply cache this result: */ + scheme_hash_set(lex_cache, key, v2l); + } else { + Scheme_Hash_Table *ht; + if (v && SCHEME_HASHTP(v)) + ht = (Scheme_Hash_Table *)v; + else { + ht = scheme_make_hash_table(SCHEME_hash_ptr); + } + if (v && !SCHEME_HASHTP(v)) + scheme_hash_set(ht, scheme_false, v); + scheme_hash_set(ht, prev_prec_ribs ? prev_prec_ribs : scheme_false, v2l); + scheme_hash_set(lex_cache, key, (Scheme_Object *)ht); + } + end_mutable = v2l; + } + + stack = SCHEME_CDR(stack); + } + + EXPLAIN_R(printf(" ... done\n")); + + return v2l; +} + +static Scheme_Object *wraps_to_datum(Scheme_Object *stx_datum, + Scheme_Object *w_in, + Scheme_Marshal_Tables *mt, + Scheme_Hash_Table *rns, + int just_simplify) +{ + Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *prec_ribs = scheme_null; + WRAP_POS w; + Scheme_Hash_Table *lex_cache, *reverse_map; + int stack_size = 0, specific_to_datum = 0; + + if (!rns) + rns = mt->rns; + + if (just_simplify) { + a = scheme_hash_get(rns, w_in); + } else { + if (mt->same_map) { + a = scheme_hash_get(mt->same_map, w_in); + if (a) + w_in = a; + } + a = scheme_marshal_lookup(mt, w_in); + } + if (a) { + if (just_simplify) + return a; + else { + scheme_marshal_using_key(mt, w_in); + return a; + } + } + + WRAP_POS_INIT(w, w_in); + + stack = scheme_null; + + lex_cache = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_void); + if (!lex_cache) { + lex_cache = scheme_make_hash_table(SCHEME_hash_ptr); + scheme_hash_set(rns, scheme_void, (Scheme_Object *)lex_cache); + } + + if (!just_simplify) + stx_datum = scheme_false; + + /* Ensures that all lexical tables in w have been simplified */ + simplifies = simplify_lex_renames(w_in, lex_cache, stx_datum); + + if (mt) + scheme_marshal_push_refs(mt); + + while (!WRAP_POS_END_P(w)) { + a = WRAP_POS_FIRST(w); + old_key = WRAP_POS_KEY(w); + WRAP_POS_INC(w); + if (SCHEME_NUMBERP(a)) { + /* Mark numbers get parenthesized */ + if (!WRAP_POS_END_P(w) && SAME_OBJ(a, WRAP_POS_FIRST(w))) + WRAP_POS_INC(w); /* delete cancelled mark */ + else { + if (just_simplify) + stack = CONS(a, stack); + else + stack = CONS(CONS(a, scheme_null), stack); + stack_size++; + } + } else if (SCHEME_VECTORP(a) + || SCHEME_RIBP(a)) { + if (SCHEME_RIBP(a) || (SCHEME_VEC_SIZE(a) > 2)) { + + if (SCHEME_RIBP(a) || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[2])) { + /* a is not a simplified table; need to look it up; if + simplifies is non-null, then we already have found a list + of simplified tables for the current wrap segment. */ + if (SCHEME_RIBP(a)) { + if (nonempty_rib((Scheme_Lexical_Rib *)a)) + prec_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, prec_ribs); + } + a = SCHEME_CAR(simplifies); + /* used up one simplification: */ + simplifies = SCHEME_CDR(simplifies); + } + + /* Simplification may have left us with the null table: */ + if (SCHEME_VEC_SIZE(a) > 2) { + if (just_simplify) { + stack = CONS(a, stack); + } else { + Scheme_Object *local_key; + + local_key = scheme_marshal_lookup(mt, a); + if (local_key) { + scheme_marshal_using_key(mt, a); + a = local_key; + } else { + a = scheme_marshal_wrap_set(mt, a, a); + } + stack = CONS(a, stack); + } + stack_size++; + } + } + /* else empty simplified vector, which we drop */ + } else if (SCHEME_RIB_DELIMP(a)) { + /* simpliciation eliminates the need for rib delimiters */ + } else if (SCHEME_RENAMESP(a) + || SCHEME_RENAMES_SETP(a)) { + int which = 0; + + while (1) { + Module_Renames *mrn; + int redundant = 0; + + if (SCHEME_RENAMESP(a)) { + if (!which) { + mrn = (Module_Renames *)a; + which++; + } else + break; + } else { + /* flatten sets */ + Module_Renames_Set *s = (Module_Renames_Set *)a; + mrn = NULL; + while (!mrn + && (which - 2 < (s->other_phases + ? s->other_phases->size + : 0))) { + if (!which) + mrn = s->rt; + else if (which == 1) + mrn = s->et; + else + mrn = (Module_Renames *)s->other_phases->vals[which - 2]; + which++; + } + if (!mrn + && (which - 2 >= (s->other_phases + ? s->other_phases->size + : 0))) + break; + } + + if (mrn) { + if (mrn->kind == mzMOD_RENAME_MARKED) { + /* Not useful if there's no marked names. */ + redundant = ((mrn->sealed >= STX_SEAL_ALL) + && (!mrn->marked_names || !mrn->marked_names->count) + && (!mrn->free_id_renames || !mrn->free_id_renames->count) + && SCHEME_NULLP(mrn->shared_pes)); + if (!redundant) { + /* Otherwise, watch out for multiple instances of the same rename: */ + WRAP_POS l; + Scheme_Object *la; + + WRAP_POS_COPY(l,w); + + for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { + la = WRAP_POS_FIRST(l); + if (SAME_OBJ(a, la)) { + redundant = 1; + break; + } + } + } + } else { + /* Check for later [non]module rename at the same phase: */ + Scheme_Object *phase; + WRAP_POS l; + Scheme_Object *la; + + WRAP_POS_COPY(l,w); + + phase = mrn->phase; + + for (; !WRAP_POS_END_P(l); WRAP_POS_INC(l)) { + la = WRAP_POS_FIRST(l); + if (SCHEME_RENAMESP(la)) { + Module_Renames *lrn = (Module_Renames *)WRAP_POS_FIRST(l); + if ((lrn->kind == mrn->kind) + && (same_phase(lrn->phase, phase))) { + /* mrn is redundant */ + redundant = 1; + break; + } + } else if (SCHEME_RENAMES_SETP(la)) { + Module_Renames_Set *s = (Module_Renames_Set *)WRAP_POS_FIRST(l); + if ((s->kind == mrn->kind) + && extract_renames(s, phase)) { + redundant = 1; + break; + } + } else if (SCHEME_BOXP(la)) { + if (SCHEME_TRUEP(phase)) + phase = scheme_bin_minus(phase, + SCHEME_VEC_ELS(SCHEME_PTR_VAL(WRAP_POS_FIRST(l)))[0]); + } + } + } + + if (!redundant) { + if (just_simplify) { + stack = CONS((Scheme_Object *)mrn, stack); + } else { + if (mrn->free_id_renames) { + /* resolve all renamings */ + int i; + Scheme_Object *b; + for (i = mrn->free_id_renames->size; i--; ) { + if (mrn->free_id_renames->vals[i]) { + if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { + int sealed; + Scheme_Hash_Table *free_id_recur; + + free_id_recur = make_recur_table(); + b = extract_module_free_id_binding((Scheme_Object *)mrn, + mrn->free_id_renames->keys[i], + mrn->free_id_renames->vals[i], + &sealed, + free_id_recur); + release_recur_table(free_id_recur); + if (!sealed) { + scheme_signal_error("write: unsealed local-definition or module context" + " found in syntax object"); + } + scheme_hash_set(mrn->free_id_renames, mrn->free_id_renames->keys[i], b); + } + } + } + } + + if (mrn->kind == mzMOD_RENAME_TOPLEVEL) { + if (same_phase(mrn->phase, scheme_make_integer(0))) + stack = CONS(scheme_true, stack); + else + stack = CONS(scheme_false, stack); + } else { + Scheme_Object *local_key; + + local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn); + if (!local_key) { + /* Convert hash table to vector, etc.: */ + int i, j, count = 0; + Scheme_Hash_Table *ht; + Scheme_Object *l, *fil; + + ht = mrn->ht; + count = ht->count; + l = scheme_make_vector(count * 2, NULL); + for (i = ht->size, j = 0; i--; ) { + if (ht->vals[i]) { + SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; + fil = ht->vals[i]; + if (SCHEME_PAIRP(fil) && is_rename_inspector_info(SCHEME_CAR(fil))) { + /* use 1 or 2 to indicate inspector info */ + if (SCHEME_PAIRP(SCHEME_CAR(fil))) + fil = CONS(scheme_make_integer(2), SCHEME_CDR(fil)); + else + fil = CONS(scheme_make_integer(1), SCHEME_CDR(fil)); + } + SCHEME_VEC_ELS(l)[j++] = fil; + } + } + + ht = mrn->free_id_renames; + if (ht && ht->count) { + count = ht->count; + fil = scheme_make_vector(count * 2, NULL); + for (i = ht->size, j = 0; i--; ) { + if (ht->vals[i]) { + SCHEME_VEC_ELS(fil)[j++] = ht->keys[i]; + SCHEME_VEC_ELS(fil)[j++] = ht->vals[i]; + } + } + } else + fil = NULL; + + if (mrn->marked_names && mrn->marked_names->count) { + Scheme_Object *d = scheme_null, *p; + + for (i = mrn->marked_names->size; i--; ) { + if (mrn->marked_names->vals[i] + /* #f mapping used to store reverse-map cache: */ + && !SCHEME_FALSEP(mrn->marked_names->keys[i])) { + p = CONS(mrn->marked_names->keys[i], + mrn->marked_names->vals[i]); + d = CONS(p, d); + } + } + + if (fil) + fil = CONS(fil, d); + else + fil = d; + } else if (fil) + fil = CONS(fil, scheme_null); + else + fil = scheme_null; + + l = CONS(l, fil); + + if (SCHEME_PAIRP(mrn->unmarshal_info)) + l = CONS(mrn->unmarshal_info, l); + + l = CONS(mrn->set_identity, l); + l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l); + l = CONS(mrn->phase, l); + + local_key = scheme_marshal_lookup(mt, a); + if (local_key) + scheme_marshal_using_key(mt, a); + else { + local_key = scheme_marshal_wrap_set(mt, a, l); + } + } else { + scheme_marshal_using_key(mt, (Scheme_Object *)mrn); + } + stack = CONS(local_key, stack); + } + } + stack_size++; + } + } + } + } else if (SCHEME_SYMBOLP(a)) { + /* mark barrier */ + stack = CONS(a, stack); + stack_size++; + } else if (SCHEME_HASHTP(a)) { + /* chain-specific cache; drop it */ + } else if (SCHEME_PRUNEP(a)) { + if (SCHEME_SYMBOLP(stx_datum)) { + /* Assuming that there are lex renames later, then this chain is + specific to this wrap. */ + specific_to_datum = 1; + } + if (!just_simplify) + a = scheme_box(SCHEME_BOX_VAL(a)); + stack = CONS(a, stack); + stack_size++; + } else { + /* box, a phase shift */ + /* We used to drop a phase shift if there are no following + rename tables. However, the phase shift also identifies + the source module, which can be relevant. So, keep the + phase shift. */ + /* Need the phase shift, but drop the export table, if any: */ + Scheme_Object *local_key; + Scheme_Object *aa; + + aa = SCHEME_BOX_VAL(a); + if (SCHEME_TRUEP(SCHEME_VEC_ELS(aa)[3])) { + if (mt) + a = scheme_hash_get(mt->shift_map, aa); + else + a = scheme_hash_get(rns, aa); + if (!a) { + a = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(a)[0] = SCHEME_VEC_ELS(aa)[0]; + SCHEME_VEC_ELS(a)[1] = SCHEME_VEC_ELS(aa)[1]; + SCHEME_VEC_ELS(a)[2] = SCHEME_VEC_ELS(aa)[2]; + SCHEME_VEC_ELS(a)[3] = scheme_false; + a = scheme_box(a); + scheme_hash_set(rns, aa, a); + } + } + + if (!just_simplify) { + local_key = scheme_marshal_lookup(mt, a); + if (local_key) { + scheme_marshal_using_key(mt, a); + a = local_key; + } else { + a = scheme_marshal_wrap_set(mt, a, a); + } + } + + stack = CONS(a, stack); + stack_size++; + } + } + + /* Double-check for equivalent list in table (after simplification): */ + if (mt && mt->pass) { + /* No need to check for later passes, since mt->same_map + covers the equivalence. */ + } else { + if (mt) { + reverse_map = mt->reverse_map; + } else { + reverse_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_undefined); + } + if (!reverse_map) { + reverse_map = scheme_make_hash_table_equal(); + if (mt) + mt->reverse_map = reverse_map; + else + scheme_hash_set(rns, scheme_undefined, (Scheme_Object *)reverse_map); + } + old_key = scheme_hash_get(reverse_map, stack); + if (old_key) { + if (just_simplify) { + return scheme_hash_get(rns, old_key); + } else { + a = scheme_marshal_lookup(mt, old_key); + scheme_marshal_using_key(mt, old_key); + if (!mt->same_map) { + Scheme_Hash_Table *same_map; + same_map = scheme_make_hash_table(SCHEME_hash_ptr); + mt->same_map = same_map; + } + scheme_hash_set(mt->same_map, w_in, old_key); + /* nevermind references that we saw when creating `stack': */ + scheme_marshal_pop_refs(mt, 0); + return a; + } + } + + if (!specific_to_datum) + scheme_hash_set(reverse_map, stack, w_in); + } + + /* Convert to a chunk if just simplifying. + (Note that we do this after looking for equivalent stacks.) */ + if (just_simplify) { + if (stack_size) { + Wrap_Chunk *wc; + int i; + wc = MALLOC_WRAP_CHUNK(stack_size); + wc->type = scheme_wrap_chunk_type; + wc->len = stack_size; + for (i = stack_size; i--; stack = SCHEME_CDR(stack)) { + wc->a[i] = SCHEME_CAR(stack); + } + stack = CONS((Scheme_Object *)wc, scheme_null); + } else + stack= scheme_null; + } + + if (mt) { + /* preserve references that we saw when creating `stack': */ + scheme_marshal_pop_refs(mt, 1); + } + + /* Remember this wrap set: */ + if (just_simplify) { + if (!specific_to_datum) + scheme_hash_set(rns, w_in, stack); + return stack; + } else { + return scheme_marshal_wrap_set(mt, w_in, stack); + } +} + +/*========================================================================*/ +/* syntax->datum */ +/*========================================================================*/ + +/* This code can convert a syntax object plus its wraps to something + writeable. In that case, the result is a : + + = (vector ) + | + = | ... + + = (cons (cons (cons ... )) ) + | (cons (cons ... null) ) + | (cons (cons #t ) ) + ; where has no boxes or vectors, and + ; is shared in all elements + = (cons (box ) ) + = (cons (vector ...) ) + = (cons ) + ; where is not a pair, vector, or box +*/ + +static Scheme_Object *extract_for_common_wrap(Scheme_Object *a, int get_mark, int pair_ok) +{ + /* We only share wraps for things constucted with pairs and + atomic (w.r.t. syntax) values, where there are no certificates + on any of the sub-parts. */ + Scheme_Object *v; + + if (SCHEME_PAIRP(a)) { + v = SCHEME_CAR(a); + + if (SCHEME_PAIRP(v)) { + if (pair_ok && SAME_OBJ(SCHEME_CAR(v), scheme_true)) { + /* A pair with shared wraps for its elements */ + if (get_mark) + return SCHEME_CDR(a); + else + return SCHEME_CDR(v); + } + } else if (!SCHEME_BOXP(v) && !SCHEME_VECTORP(v)) { + /* It's atomic. */ + if (get_mark) + return SCHEME_CDR(a); + else + return v; + } + } + + return NULL; +} + +static void lift_common_wraps(Scheme_Object *l, Scheme_Object *common_wraps, int cnt, int tail) +{ + Scheme_Object *a; + + while (cnt--) { + a = SCHEME_CAR(l); + a = extract_for_common_wrap(a, 0, 1); + SCHEME_CAR(l) = a; + if (cnt) + l = SCHEME_CDR(l); + } + if (tail) { + a = SCHEME_CDR(l); + a = extract_for_common_wrap(a, 0, 0); + SCHEME_CDR(l) = a; + } +} + +static Scheme_Object *record_certs(Scheme_Object *cert_marks, Scheme_Marshal_Tables *mt) +{ + Scheme_Object *v, *local_key; + + if (SCHEME_PAIRP(cert_marks)) { + v = scheme_hash_get(mt->cert_lists, cert_marks); + if (!v) { + scheme_hash_set(mt->cert_lists, cert_marks, cert_marks); + v = cert_marks; + } + + local_key = scheme_marshal_lookup(mt, v); + if (local_key) { + scheme_marshal_using_key(mt, v); + return local_key; + } else { + return scheme_marshal_wrap_set(mt, v, v); + } + } else + return scheme_null; +} + +#ifdef DO_STACK_CHECK +static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, + int with_marks, + Scheme_Marshal_Tables *mt); + +static Scheme_Object *syntax_to_datum_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p3 = NULL; + + return syntax_to_datum_inner(o, p->ku.k.i1, mt); +} +#endif + +static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o, + int with_marks, + Scheme_Marshal_Tables *mt) +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + Scheme_Object *v, *result, *converted_wraps = NULL; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)o; + p->ku.k.i1 = with_marks; + p->ku.k.p3 = (void *)mt; + return scheme_handle_stack_overflow(syntax_to_datum_k); + } + } +#endif + SCHEME_USE_FUEL(1); + + if (with_marks) { + /* Propagate wraps: */ + scheme_stx_content((Scheme_Object *)stx); + } + + v = stx->val; + + if (SCHEME_PAIRP(v)) { + Scheme_Object *first = NULL, *last = NULL, *p, *common_wraps = NULL; + int cnt = 0; + + while (SCHEME_PAIRP(v)) { + Scheme_Object *a; + + cnt++; + + a = syntax_to_datum_inner(SCHEME_CAR(v), with_marks, mt); + + p = CONS(a, scheme_null); + + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + v = SCHEME_CDR(v); + + if (with_marks) { + a = extract_for_common_wrap(a, 1, 1); + if (!common_wraps) { + if (a) + common_wraps = a; + else + common_wraps = scheme_false; + } else if (!a || !SAME_OBJ(common_wraps, a)) + common_wraps = scheme_false; + } + } + if (!SCHEME_NULLP(v)) { + v = syntax_to_datum_inner(v, with_marks, mt); + SCHEME_CDR(last) = v; + + if (with_marks) { + v = extract_for_common_wrap(v, 1, 0); + if (v && SAME_OBJ(common_wraps, v)) { + converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); + if (SAME_OBJ(common_wraps, converted_wraps)) + lift_common_wraps(first, common_wraps, cnt, 1); + else + common_wraps = scheme_false; + } else + common_wraps = scheme_false; + } + + if ((with_marks > 1) && SCHEME_FALSEP(common_wraps)) { + /* v is likely a pair, and v's car might be a pair, + which means that the datum->syntax part + won't be able to detect that v is a "non-pair" + terminal. Therefore, we communicate the + length before the terminal to datum->syntax: */ + first = scheme_make_pair(scheme_make_integer(cnt), first); + } + } else if (with_marks && SCHEME_TRUEP(common_wraps)) { + converted_wraps = wraps_to_datum(scheme_false, stx->wraps, mt, NULL, 0); + if (SAME_OBJ(common_wraps, converted_wraps)) + lift_common_wraps(first, common_wraps, cnt, 0); + else + common_wraps = scheme_false; + } + + if (with_marks && SCHEME_TRUEP(common_wraps)) { + first = scheme_make_pair(scheme_true, first); + } + + result = first; + } else if (SCHEME_BOXP(v)) { + v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), with_marks, mt); + result = scheme_box(v); + SCHEME_SET_IMMUTABLE(result); + } else if (SCHEME_VECTORP(v)) { + int size = SCHEME_VEC_SIZE(v), i; + Scheme_Object *r, *a; + + r = scheme_make_vector(size, NULL); + + for (i = 0; i < size; i++) { + a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], with_marks, mt); + SCHEME_VEC_ELS(r)[i] = a; + } + + result = r; + SCHEME_SET_IMMUTABLE(result); + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v, *ht2; + Scheme_Object *key, *val; + int i; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht) & 0x3); + + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + val = syntax_to_datum_inner(val, with_marks, mt); + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht, i); + } + + result = (Scheme_Object *)ht2; + } else if (prefab_p(v)) { + Scheme_Structure *s = (Scheme_Structure *)v; + Scheme_Object *a; + int size = s->stype->num_slots, i; + + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance(s); + for (i = 0; i < size; i++) { + a = syntax_to_datum_inner(s->slots[i], with_marks, mt); + s->slots[i] = a; + } + + result = (Scheme_Object *)s; + } else + result = v; + + if (with_marks > 1) { + if (!converted_wraps) + converted_wraps = wraps_to_datum(stx->val, stx->wraps, mt, NULL, 0); + result = CONS(result, converted_wraps); + if (stx->certs) { + Scheme_Object *cert_marks = scheme_null, *icert_marks = scheme_null; + Scheme_Cert *certs; + + certs = ACTIVE_CERTS(stx); + while (certs) { + cert_marks = scheme_make_pair(certs->modidx, cert_marks); + cert_marks = scheme_make_pair(certs->mark, cert_marks); + certs = certs->next; + } + certs = INACTIVE_CERTS(stx); + while (certs) { + icert_marks = scheme_make_pair(certs->modidx, icert_marks); + icert_marks = scheme_make_pair(certs->mark, icert_marks); + certs = certs->next; + } + + if (SCHEME_PAIRP(cert_marks) + || SCHEME_PAIRP(icert_marks)) { + + cert_marks = record_certs(cert_marks, mt); + icert_marks = record_certs(icert_marks, mt); + + v = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(v)[0] = result; + if (!SCHEME_NULLP(icert_marks)) { + cert_marks = scheme_make_pair(cert_marks, icert_marks); + if (SCHEME_NUMBERP(SCHEME_CAR(cert_marks))) + cert_marks = scheme_make_pair(scheme_false, cert_marks); + } + SCHEME_VEC_ELS(v)[1] = cert_marks; + result = v; + } + } + } + + return result; +} + +Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks, + Scheme_Marshal_Tables *mt) +{ + Scheme_Object *v; + + if (mt) + scheme_marshal_push_refs(mt); + + v = syntax_to_datum_inner(stx, with_marks, mt); + + if (mt) { + /* A symbol+wrap combination is likely to be used multiple + times. This is a relatively minor optimization in .zo size, + since v is already fairly compact, but it also avoids + allocating extra syntax objects at load time. For consistency, + we try to reuse all combinations. */ + Scheme_Hash_Table *top_map; + Scheme_Object *key; + + top_map = mt->top_map; + if (!top_map) { + top_map = scheme_make_hash_table_equal(); + mt->top_map = top_map; + } + + key = scheme_hash_get(top_map, v); + if (key) { + scheme_marshal_pop_refs(mt, 0); + v = scheme_marshal_lookup(mt, key); + scheme_marshal_using_key(mt, key); + } else { + scheme_hash_set(top_map, stx, v); + v = scheme_marshal_wrap_set(mt, stx, v); + scheme_marshal_pop_refs(mt, 1); + } + } + + return v; +} + +/*========================================================================*/ +/* datum->wraps */ +/*========================================================================*/ + +static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Unmarshal_Tables *ut) +{ + Scheme_Object *n, *a = _a; + + if (SCHEME_INTP(a) && IS_POSMARK(a)) + a = scheme_make_integer(-SCHEME_INT_VAL(a)); + else if (!SCHEME_NUMBERP(a)) + return NULL; + else + a = scheme_intern_symbol(scheme_number_to_string(10, a)); + + /* Picked a mapping yet? */ + n = scheme_hash_get(ut->rns, a); + if (!n) { + /* Map marshaled mark to a new mark. */ + n = scheme_new_mark(); + if (!IS_POSMARK(_a)) { + /* Map negative mark to negative mark: */ + n = negate_mark(n); + } + scheme_hash_set(ut->rns, a, n); + } + + /* Really a mark? */ + if (!SCHEME_NUMBERP(n)) + return NULL; + + return n; +} + +#if 0 +# define return_NULL return (printf("%d\n", __LINE__), NULL) +#else +# define return_NULL return NULL +#endif + +static int ok_phase(Scheme_Object *o) { + return (SCHEME_INTP(o) || SCHEME_BIGNUMP(o) || SCHEME_FALSEP(o)); +} +static int ok_phase_index(Scheme_Object *o) { + return ok_phase(o); +} + +static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok, + Scheme_Unmarshal_Tables *ut) +{ + int count, i; + Scheme_Object *key, *p0, *p; + + if (!SCHEME_VECTORP(a)) return_NULL; + count = SCHEME_VEC_SIZE(a); + if (count & 0x1) return_NULL; + + for (i = 0; i < count; i+= 2) { + key = SCHEME_VEC_ELS(a)[i]; + p0 = SCHEME_VEC_ELS(a)[i+1]; + + if (!SCHEME_SYMBOLP(key)) return_NULL; + + p = p0; + if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) { + /* reconstruct inspector info */ + Scheme_Object *insp; + if (ut) + insp = scheme_get_cport_inspector(ut->rp); + else + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) { + insp = CONS(scheme_make_inspector(insp), insp); + } + p = SCHEME_CDR(p0); + p0 = CONS(insp, p); + } + + if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { + /* Ok */ + } else if (SCHEME_PAIRP(p)) { + Scheme_Object *midx; + + midx = SCHEME_CAR(p); + if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) + return_NULL; + + if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { + /* Ok */ + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { + /* Ok */ + } else { + Scheme_Object *ap, *bp; + + ap = SCHEME_CDR(p); + if (!SCHEME_PAIRP(ap)) + return_NULL; + + /* mod-phase, maybe */ + if (SCHEME_INTP(SCHEME_CAR(ap))) { + bp = SCHEME_CDR(ap); + } else + bp = ap; + + /* exportname */ + if (!SCHEME_PAIRP(bp)) + return_NULL; + ap = SCHEME_CAR(bp); + if (!SCHEME_SYMBOLP(ap)) + return_NULL; + + /* nominal_modidx_plus_phase */ + bp = SCHEME_CDR(bp); + if (!SCHEME_PAIRP(bp)) + return_NULL; + ap = SCHEME_CAR(bp); + if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { + /* Ok */ + } else if (SCHEME_PAIRP(ap)) { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) + return_NULL; + ap = SCHEME_CDR(ap); + /* import_phase_plus_nominal_phase */ + if (SCHEME_PAIRP(ap)) { + if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL; + if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL; + } else if (!ok_phase_index(ap)) + return_NULL; + } else + return_NULL; + + /* nominal_exportname */ + ap = SCHEME_CDR(bp); + if (!SCHEME_SYMBOLP(ap)) + return_NULL; + } + } else if (lex_ok) { + Scheme_Object *ap; + if (!SCHEME_BOXP(p)) + return_NULL; + ap = SCHEME_BOX_VAL(p); + if (!SCHEME_PAIRP(ap)) + return_NULL; + if (!SCHEME_SYMBOLP(SCHEME_CAR(ap))) + return_NULL; + ap = SCHEME_CDR(ap); + if (!SCHEME_SYMBOLP(ap) && !SCHEME_FALSEP(ap)) + return_NULL; + } else + return_NULL; + + scheme_hash_set(ht, key, p0); + } + + return scheme_true; +} + +static Scheme_Object *datum_to_wraps(Scheme_Object *w, + Scheme_Unmarshal_Tables *ut) +{ + Scheme_Object *a, *wraps_key, *local_key; + int stack_size, decoded; + Wrap_Chunk *wc; + + /* ut->rns maps numbers (table indices) to renaming tables, and negative + numbers (negated fixnum marks) and symbols (interned marks) to marks.*/ + + /* This function has to be defensive, since `w' can originate in + untrusted .zo bytecodes. Return NULL for bad wraps. */ + + if (SCHEME_INTP(w)) { + wraps_key = w; + w = scheme_unmarshal_wrap_get(ut, wraps_key, &decoded); + if (decoded && (!w || !SCHEME_LISTP(w))) /* list => a wrap, as opposed to a mark, etc. */ + return_NULL; + if (decoded) + return w; + } else { + /* not shared */ + wraps_key = NULL; + } + + stack_size = scheme_proper_list_length(w); + if (stack_size < 1) { + scheme_unmarshal_wrap_set(ut, wraps_key, scheme_null); + return scheme_null; + } else if (stack_size < 2) { + wc = NULL; + } else { + wc = MALLOC_WRAP_CHUNK(stack_size); + wc->type = scheme_wrap_chunk_type; + wc->len = stack_size; + } + + a = NULL; + + while (!SCHEME_NULLP(w)) { + a = SCHEME_CAR(w); + if (SCHEME_NUMBERP(a)) { + /* Re-use rename table or env rename */ + local_key = a; + a = scheme_unmarshal_wrap_get(ut, local_key, &decoded); + if (decoded && (!a || SCHEME_LISTP(a))) /* list => a whole wrap, no good as an element */ + return_NULL; + } else { + /* Not shared */ + local_key = NULL; + decoded = 0; + } + + if (decoded) { + /* done */ + } else if (SCHEME_PAIRP(a) + && SCHEME_NULLP(SCHEME_CDR(a)) + && SCHEME_NUMBERP(SCHEME_CAR(a))) { + /* Mark */ + a = unmarshal_mark(SCHEME_CAR(a), ut); + if (!a) return_NULL; + } else if (SCHEME_VECTORP(a)) { + /* A (simplified) rename table. */ + int sz = SCHEME_VEC_SIZE(a), cnt, i, any_free_id_renames = 0; + Scheme_Object *v; + + /* Make sure that it's a well-formed rename table. */ + if (sz < 2) + return_NULL; + cnt = (sz - 2) >> 1; + for (i = 0; i < cnt; i++) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i + 2])) + return_NULL; + v = SCHEME_VEC_ELS(a)[i + cnt + 2]; + if (SCHEME_SYMBOLP(v)) { + /* simple target-environment symbol */ + } else if (SCHEME_PAIRP(v)) { + /* target-environment symbol paired with free-id=? rename info */ + any_free_id_renames = 1; + if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) + return_NULL; + v = SCHEME_CDR(v); + if (SCHEME_PAIRP(v)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) + return_NULL; + v = SCHEME_CDR(v); + if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v)) + return_NULL; + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) { + if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1]) + || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[3]) + || !ok_phase(SCHEME_VEC_ELS(v)[4]) + || !ok_phase(SCHEME_VEC_ELS(v)[5]) + || !ok_phase(SCHEME_VEC_ELS(v)[6])) + return_NULL; + } else + return_NULL; + } else + return_NULL; + } + + SCHEME_VEC_ELS(a)[0] = (any_free_id_renames ? scheme_true : scheme_false); + + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) { + SCHEME_VEC_ELS(a)[1] = scheme_false; + maybe_install_rename_hash_table(a); + } + + /* It's ok: */ + scheme_unmarshal_wrap_set(ut, local_key, a); + } else if (SCHEME_PAIRP(a)) { + /* A rename table: + - ([#t] [unmarshal] #( ...) + . (( ( . ) ...) ...)) ; <- marked_names + where a is actually two values, one of: + - + - ( . ) + */ + Scheme_Object *mns; + Module_Renames *mrn; + Scheme_Object *p, *key; + int kind; + Scheme_Object *phase, *set_identity; + + if (!SCHEME_PAIRP(a)) return_NULL; + + /* Convert list to rename table: */ + + if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) { + scheme_signal_error("leftover plus-kernel"); + } + + if (!SCHEME_PAIRP(a)) return_NULL; + phase = SCHEME_CAR(a); + if (!ok_phase(phase)) return_NULL; + a = SCHEME_CDR(a); + + if (!SCHEME_PAIRP(a)) return_NULL; + if (SCHEME_TRUEP(SCHEME_CAR(a))) + kind = mzMOD_RENAME_MARKED; + else + kind = mzMOD_RENAME_NORMAL; + a = SCHEME_CDR(a); + + if (!SCHEME_PAIRP(a)) return_NULL; + set_identity = unmarshal_mark(SCHEME_CAR(a), ut); + if (!set_identity) return_NULL; + a = SCHEME_CDR(a); + + mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL); + mrn->set_identity = set_identity; + + if (!SCHEME_PAIRP(a)) return_NULL; + mns = SCHEME_CDR(a); + a = SCHEME_CAR(a); + + if (!SCHEME_VECTORP(a)) { + /* Unmarshall info: */ + Scheme_Object *ml = a, *mli, *first = scheme_null, *last = NULL, *ai; + while (SCHEME_PAIRP(ml)) { + ai = SCHEME_CAR(ml); + mli = ai; + if (!SCHEME_PAIRP(mli)) return_NULL; + + /* A module path index: */ + p = SCHEME_CAR(mli); + if (!(SCHEME_SYMBOLP(p) + || SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type))) + return_NULL; + mli = SCHEME_CDR(mli); + + if (!SCHEME_PAIRP(mli)) return_NULL; + + /* A phase/dimension index k */ + p = SCHEME_CAR(mli); + if (!ok_phase_index(p)) + return_NULL; + + p = SCHEME_CDR(mli); + if (SCHEME_PAIRP(p) && SCHEME_PAIRP(SCHEME_CAR(p))) { + /* list of marks: */ + Scheme_Object *m_first = scheme_null, *m_last = NULL, *mp, *after_marks; + + after_marks = SCHEME_CDR(p); + mli = SCHEME_CAR(p); + + while (SCHEME_PAIRP(mli)) { + p = SCHEME_CAR(mli); + p = unmarshal_mark(p, ut); + if (!p) return_NULL; + + mp = scheme_make_pair(p, scheme_null); + if (m_last) + SCHEME_CDR(m_last) = mp; + else + m_first = mp; + m_last = mp; + + mli = SCHEME_CDR(mli); + } + + /* Rebuild for unmarshaled marks: */ + ai = scheme_make_pair(SCHEME_CAR(ai), + scheme_make_pair(SCHEME_CADR(ai), + scheme_make_pair(m_first, after_marks))); + + if (!SCHEME_NULLP(mli)) return_NULL; + p = after_marks; + } + + if (ok_phase_index(p)) { + /* For a shared table: src-phase-index */ + } else { + /* For a non-shared table: (list* src-phase-index exceptions prefix), after k */ + mli = p; + if (!SCHEME_PAIRP(mli)) return_NULL; + + p = SCHEME_CAR(mli); + if (!ok_phase_index(p)) + return_NULL; + mli = SCHEME_CDR(mli); + + if (!SCHEME_PAIRP(mli)) return_NULL; + + /* A list of symbols: */ + p = SCHEME_CAR(mli); + while (SCHEME_PAIRP(p)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return_NULL; + p = SCHEME_CDR(p); + } + if (!SCHEME_NULLP(p)) return_NULL; + + /* #f or a symbol: */ + p = SCHEME_CDR(mli); + if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return_NULL; + } + + ml = SCHEME_CDR(ml); + + /* rebuild, in case we converted marks */ + p = scheme_make_pair(ai, scheme_null); + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + } + if (!SCHEME_NULLP(ml)) return_NULL; + + mrn->unmarshal_info = first; + if (SCHEME_PAIRP(first)) + mrn->needs_unmarshal = 1; + + if (!SCHEME_PAIRP(mns)) return_NULL; + a = SCHEME_CAR(mns); + mns = SCHEME_CDR(mns); + } + + if (!datum_to_module_renames(a, mrn->ht, 0, ut)) + return_NULL; + + /* Extract free-id=? renames, if any */ + if (SCHEME_PAIRP(mns) && SCHEME_VECTORP(SCHEME_CAR(mns))) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + mrn->free_id_renames = ht; + if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1, ut)) + return_NULL; + mns = SCHEME_CDR(mns); + } + + /* Extract the mark-rename table, if any: */ + if (SCHEME_PAIRP(mns)) { + Scheme_Hash_Table *ht; + Scheme_Object *ll, *kkey, *kfirst, *klast, *kp; + + ht = scheme_make_hash_table(SCHEME_hash_ptr); + for (; SCHEME_PAIRP(mns); mns = SCHEME_CDR(mns)) { + p = SCHEME_CAR(mns); + if (!SCHEME_PAIRP(p)) return_NULL; + key = SCHEME_CAR(p); + p = SCHEME_CDR(p); + if (!SCHEME_SYMBOLP(key)) return_NULL; + + ll = scheme_null; + + /* Convert marks */ + for (; SCHEME_PAIRP(p); p = SCHEME_CDR(p)) { + a = SCHEME_CAR(p); + if (!SCHEME_PAIRP(a)) return_NULL; + kkey = SCHEME_CDR(a); + if (!SCHEME_SYMBOLP(kkey)) return_NULL; + + kfirst = scheme_null; + klast = NULL; + a = SCHEME_CAR(a); + if (SCHEME_MARKP(a)) { + kfirst = unmarshal_mark(a, ut); + } else { + Scheme_Object *bdg = NULL; + + if (SCHEME_VECTORP(a)) { + if (SCHEME_VEC_SIZE(a) != 2) return_NULL; + bdg = SCHEME_VEC_ELS(a)[1]; + if (!SCHEME_SYMBOLP(bdg)) return_NULL; + a = SCHEME_VEC_ELS(a)[0]; + } + + for (; SCHEME_PAIRP(a); a = SCHEME_CDR(a)) { + kp = CONS(unmarshal_mark(SCHEME_CAR(a), ut), scheme_null); + if (!klast) + kfirst = kp; + else + SCHEME_CDR(klast) = kp; + klast = kp; + } + if (!SCHEME_NULLP(a)) { + if (bdg && SCHEME_MARKP(a) && SCHEME_NULLP(kfirst)) + kfirst = unmarshal_mark(a, ut); + else + return_NULL; + } + + if (bdg) { + a = scheme_make_vector(2, NULL); + SCHEME_VEC_ELS(a)[0] = kfirst; + SCHEME_VEC_ELS(a)[1] = bdg; + kfirst = a; + } + } + + ll = CONS(CONS(kfirst, kkey), ll); + } + + scheme_hash_set(ht, key, ll); + + if (!SCHEME_NULLP(p)) return_NULL; + } + if (!SCHEME_NULLP(mns)) return_NULL; + + mrn->marked_names = ht; + } + + scheme_unmarshal_wrap_set(ut, local_key, (Scheme_Object *)mrn); + + scheme_seal_module_rename((Scheme_Object *)mrn, STX_SEAL_ALL); + + a = (Scheme_Object *)mrn; + } else if (SAME_OBJ(a, scheme_true) + || SCHEME_FALSEP(a)) { + /* current env rename */ + Scheme_Env *env; + + env = scheme_get_env(NULL); + scheme_prepare_env_renames(env, mzMOD_RENAME_TOPLEVEL); + a = scheme_get_module_rename_from_set(env->rename_set, + (SCHEME_FALSEP(a) + ? scheme_make_integer(1) + : scheme_make_integer(0)), + 1); + } else if (SCHEME_SYMBOLP(a)) { + /* mark barrier */ + } else if (SCHEME_BOXP(a)) { + if (SCHEME_PAIRP(SCHEME_BOX_VAL(a))) { + /* prune context */ + a = make_prune_context(SCHEME_BOX_VAL(a)); + } else { + /* must be a phase shift */ + Scheme_Object *vec; + vec = SCHEME_BOX_VAL(a); + if (!SCHEME_VECTORP(vec)) return_NULL; + if (SCHEME_VEC_SIZE(vec) != 4) return_NULL; + } + } else { + return_NULL; + } + + if (wc) + wc->a[--stack_size] = a; + + w = SCHEME_CDR(w); + } + + if (wc) + a = (Scheme_Object *)wc; + a = CONS(a, scheme_null); + + scheme_unmarshal_wrap_set(ut, wraps_key, a); + + return a; +} + +/*========================================================================*/ +/* datum->syntax */ +/*========================================================================*/ + + +#ifdef DO_STACK_CHECK +static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, + Scheme_Unmarshal_Tables *ut, + Scheme_Stx *stx_src, + Scheme_Stx *stx_wraps, + Scheme_Hash_Table *ht); + +Scheme_Object *cert_marks_to_certs(Scheme_Object *cert_marks, + Scheme_Unmarshal_Tables *ut, + Scheme_Stx *stx_wraps, int *bad) +{ + /* Need to convert a list of marks to certs */ + Scheme_Cert *certs = NULL; + Scheme_Object *a, *b, *insp, *orig = cert_marks; + + if (SCHEME_NUMBERP(cert_marks)) { + /* Re-use rename table or env rename */ + int decoded; + a = scheme_unmarshal_wrap_get(ut, cert_marks, &decoded); + if (decoded && !a) + return_NULL; + if (decoded) + return a; + cert_marks = a; + } + + if (ut) + insp = scheme_get_cport_inspector(ut->rp); + else + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + + while (SCHEME_PAIRP(cert_marks)) { + a = SCHEME_CAR(cert_marks); + if (!SCHEME_NUMBERP(a)) { + *bad = 1; + return_NULL; + } + a = unmarshal_mark(a, ut); + if (!a) { *bad = 1; return_NULL; } + + cert_marks = SCHEME_CDR(cert_marks); + if (!SCHEME_PAIRP(cert_marks)) { + *bad = 1; + return_NULL; + } + b = SCHEME_CAR(cert_marks); + if (!SCHEME_SYMBOLP(b) + && !SAME_TYPE(SCHEME_TYPE(b), scheme_module_index_type)) { + *bad = 1; + return_NULL; + } + + if (!cert_in_chain(a, NULL, certs)) + certs = cons_cert(a, b, insp, NULL, certs); + + cert_marks = SCHEME_CDR(cert_marks); + } + if (!SCHEME_NULLP(cert_marks)) { + *bad = 1; + return_NULL; + } + + if (SCHEME_NUMBERP(orig)) { + scheme_unmarshal_wrap_set(ut, orig, (Scheme_Object *)certs); + } + + return (Scheme_Object *)certs; +} + +static Scheme_Object *datum_to_syntax_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Stx *stx_src = (Scheme_Stx *)p->ku.k.p2; + Scheme_Stx *stx_wraps = (Scheme_Stx *)p->ku.k.p3; + Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p4; + Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p5; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + p->ku.k.p4 = NULL; + p->ku.k.p5 = NULL; + + return datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht); +} +#endif + +static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o, + Scheme_Unmarshal_Tables *ut, + Scheme_Stx *stx_src, + Scheme_Stx *stx_wraps, /* or rename table, or boxed precomputed wrap */ + Scheme_Hash_Table *ht) +{ + Scheme_Object *result, *wraps, *cert_marks = NULL, *hashed; + int do_not_unpack_wraps = 0; + + if (SCHEME_STXP(o)) + return o; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)o; + p->ku.k.p2 = (void *)stx_src; + p->ku.k.p3 = (void *)stx_wraps; + p->ku.k.p4 = (void *)ht; + p->ku.k.p5 = (void *)ut; + return scheme_handle_stack_overflow(datum_to_syntax_k); + } + } +#endif + + SCHEME_USE_FUEL(1); + + if (ht) { + if (HAS_CHAPERONE_SUBSTX(o)) { + if (scheme_hash_get(ht, o)) { + /* Graphs disallowed */ + return_NULL; + } + + scheme_hash_set(ht, o, scheme_true); + hashed = o; + } else + hashed = NULL; + } else + hashed = NULL; + + if (ut && !SCHEME_BOXP(stx_wraps)) { + if (SCHEME_VECTORP(o)) { + /* This one has certs */ + if (SCHEME_VEC_SIZE(o) == 2) { + cert_marks = SCHEME_VEC_ELS(o)[1]; + o = SCHEME_VEC_ELS(o)[0]; + } else + return_NULL; + } + if (!SCHEME_PAIRP(o)) + return_NULL; + wraps = SCHEME_CDR(o); + o = SCHEME_CAR(o); + } else if (SCHEME_BOXP(stx_wraps)) { + /* Shared wraps, to be used directly everywhere: */ + wraps = SCHEME_BOX_VAL(stx_wraps); + do_not_unpack_wraps = 1; + } else + wraps = NULL; + + if (SCHEME_PAIRP(o)) { + Scheme_Object *first = NULL, *last = NULL, *p; + + /* Check whether it's all conses with + syntax inside */ + p = o; + while (SCHEME_PAIRP(p)) { + if (!SCHEME_STXP(SCHEME_CAR(p))) + break; + p = SCHEME_CDR(p); + } + if (SCHEME_NULLP(p) || SCHEME_STXP(p)) { + result = o; + } else { + int cnt = -1; + Scheme_Stx *sub_stx_wraps = stx_wraps; + + if (wraps && !SCHEME_BOXP(stx_wraps) && SAME_OBJ(SCHEME_CAR(o), scheme_true)) { + /* Resolve wraps now, and then share it with + all nested objects (as indicated by a box + for stx_wraps). */ + wraps = datum_to_wraps(wraps, ut); + do_not_unpack_wraps = 1; + sub_stx_wraps = (Scheme_Stx *)scheme_box(wraps); + o = SCHEME_CDR(o); + } else if (wraps && !SCHEME_BOXP(stx_wraps) && SCHEME_INTP(SCHEME_CAR(o))) { + /* First element is the number of items + before a non-null terminal: */ + cnt = SCHEME_INT_VAL(SCHEME_CAR(o)); + o = SCHEME_CDR(o); + } + + /* Build up a new list while converting elems */ + while (SCHEME_PAIRP(o) && cnt) { + Scheme_Object *a; + + if (ht && last) { + if (scheme_hash_get(ht, o)) { + /* cdr is shared. Stop here and let someone else complain. */ + break; + } + } + + a = datum_to_syntax_inner(SCHEME_CAR(o), ut, stx_src, sub_stx_wraps, ht); + if (!a) return_NULL; + + p = scheme_make_pair(a, scheme_null); + + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + o = SCHEME_CDR(o); + + --cnt; + } + if (!SCHEME_NULLP(o)) { + o = datum_to_syntax_inner(o, ut, stx_src, sub_stx_wraps, ht); + if (!o) return_NULL; + SCHEME_CDR(last) = o; + } + + result = first; + } + } else if (SCHEME_CHAPERONE_BOXP(o)) { + if (SCHEME_NP_CHAPERONEP(o)) + o = scheme_unbox(o); + else + o = SCHEME_PTR_VAL(o); + + o = datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht); + if (!o) return_NULL; + result = scheme_box(o); + SCHEME_SET_BOX_IMMUTABLE(result); + } else if (SCHEME_CHAPERONE_VECTORP(o)) { + int size, i; + Scheme_Object *a, *oo; + + oo = o; + if (SCHEME_NP_CHAPERONEP(o)) + o = SCHEME_CHAPERONE_VAL(o); + size = SCHEME_VEC_SIZE(o); + + result = scheme_make_vector(size, NULL); + + for (i = 0; i < size; i++) { + if (SAME_OBJ(o, oo)) + a = SCHEME_VEC_ELS(o)[i]; + else + a = scheme_chaperone_vector_ref(oo, i); + a = datum_to_syntax_inner(a, ut, stx_src, stx_wraps, ht); + if (!a) return_NULL; + SCHEME_VEC_ELS(result)[i] = a; + } + + SCHEME_SET_VECTOR_IMMUTABLE(result); + } else if (SCHEME_CHAPERONE_HASHTRP(o)) { + Scheme_Hash_Tree *ht1, *ht2; + Scheme_Object *key, *val; + int i; + + if (SCHEME_NP_CHAPERONEP(o)) + ht1 = (Scheme_Hash_Tree *)SCHEME_CHAPERONE_VAL(o); + else + ht1 = (Scheme_Hash_Tree *)o; + + ht2 = scheme_make_hash_tree(SCHEME_HASHTR_FLAGS(ht1) & 0x3); + + i = scheme_hash_tree_next(ht1, -1); + while (i != -1) { + scheme_hash_tree_index(ht1, i, &key, &val); + if (!SAME_OBJ((Scheme_Object *)ht1, o)) + val = scheme_chaperone_hash_traversal_get(o, key); + val = datum_to_syntax_inner(val, ut, stx_src, stx_wraps, ht); + if (!val) return NULL; + ht2 = scheme_hash_tree_set(ht2, key, val); + i = scheme_hash_tree_next(ht1, i); + } + + result = (Scheme_Object *)ht2; + } else if (prefab_p(o) || (SCHEME_CHAPERONEP(o) && prefab_p(SCHEME_CHAPERONE_VAL(o)))) { + Scheme_Structure *s; + Scheme_Object *a; + int size, i; + + s = (Scheme_Structure *)scheme_clone_prefab_struct_instance((Scheme_Structure *)o); + size = s->stype->num_slots; + + for (i = 0; i < size; i++) { + a = datum_to_syntax_inner(s->slots[i], ut, stx_src, stx_wraps, ht); + if (!a) return NULL; + s->slots[i] = a; + } + + result = (Scheme_Object *)s; + } else { + result = o; + } + + if (SCHEME_FALSEP((Scheme_Object *)stx_src)) + result = scheme_make_stx(result, empty_srcloc, NULL); + else + result = scheme_make_stx(result, stx_src->srcloc, NULL); + + if (wraps) { + if (!do_not_unpack_wraps) { + wraps = datum_to_wraps(wraps, ut); + if (!wraps) + return_NULL; + } + ((Scheme_Stx *)result)->wraps = wraps; + } else if (SCHEME_FALSEP((Scheme_Object *)stx_wraps)) { + /* wraps already nulled */ + } else { + /* Note: no propagation will be needed for SUBSTX */ + ((Scheme_Stx *)result)->wraps = stx_wraps->wraps; + } + + if (cert_marks) { + /* Need to convert a list of marks to certs */ + Scheme_Object *certs; + int bad = 0; + + if (SCHEME_PAIRP(cert_marks) + && (SCHEME_PAIRP(SCHEME_CAR(cert_marks)) + || SCHEME_NULLP(SCHEME_CAR(cert_marks)) + || SCHEME_FALSEP(SCHEME_CAR(cert_marks)))) { + /* Have both active and inactive certs */ + Scheme_Object *icerts; + if (SCHEME_FALSEP(SCHEME_CAR(cert_marks))) + cert_marks = SCHEME_CDR(cert_marks); + certs = cert_marks_to_certs(SCHEME_CAR(cert_marks), ut, stx_wraps, &bad); + icerts = cert_marks_to_certs(SCHEME_CDR(cert_marks), ut, stx_wraps, &bad); + certs = scheme_make_raw_pair(certs, icerts); + } else { + /* Just active certs */ + certs = cert_marks_to_certs(cert_marks, ut, stx_wraps, &bad); + } + if (bad) + return_NULL; + ((Scheme_Stx *)result)->certs = certs; + } + + if (hashed) { + scheme_hash_set(ht, hashed, NULL); + } + + return result; +} + +static Scheme_Object *general_datum_to_syntax(Scheme_Object *o, + Scheme_Unmarshal_Tables *ut, + Scheme_Object *stx_src, + Scheme_Object *stx_wraps, + int can_graph, int copy_props) + /* If stx_wraps is a hash table, then `o' includes marks and certs. + If copy_props > 0, properties are copied from src. + If copy_props != 1 or 0, then certs are copied from src, too. */ +{ + Scheme_Hash_Table *ht; + Scheme_Object *v, *code = NULL; + + if (!SCHEME_FALSEP(stx_src) && !SCHEME_STXP(stx_src)) + return o; + + if (SCHEME_STXP(o)) + return o; + + if (can_graph && HAS_CHAPERONE_SUBSTX(o)) + ht = scheme_make_hash_table(SCHEME_hash_ptr); + else + ht = NULL; + + if (ut) { + /* If o is just a number, look it up in the table. */ + if (SCHEME_INTP(o)) { + int decoded; + v = scheme_unmarshal_wrap_get(ut, o, &decoded); + if (!decoded) { + code = o; + o = v; + } else + return v; + } + } + + v = datum_to_syntax_inner(o, + ut, + (Scheme_Stx *)stx_src, + (Scheme_Stx *)stx_wraps, + ht); + + if (!v) { + if (ut) + return_NULL; /* happens with bad wraps from a bad .zo */ + /* otherwise, only happens with cycles: */ + scheme_raise_exn(MZEXN_FAIL_CONTRACT, + "datum->syntax: cannot create syntax from cyclic datum: %V", + o); + return NULL; + } + + if (code) { + scheme_unmarshal_wrap_set(ut, code, v); + } + + if (copy_props > 0) + ((Scheme_Stx *)v)->props = ((Scheme_Stx *)stx_src)->props; + + if (copy_props && (copy_props != 1)) { + if (ACTIVE_CERTS(((Scheme_Stx *)stx_src))) + v = add_certs(v, ACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 1); + if (INACTIVE_CERTS((Scheme_Stx *)stx_src)) { + v = lift_inactive_certs(v, 0); + v = add_certs(v, INACTIVE_CERTS((Scheme_Stx *)stx_src), NULL, 0); + } + } + + return v; +} + +Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, + Scheme_Object *stx_src, + Scheme_Object *stx_wraps, + int can_graph, int copy_props) +{ + return general_datum_to_syntax(o, NULL, stx_src, stx_wraps, can_graph, copy_props); +} + +Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o, + struct Scheme_Unmarshal_Tables *ut, + int can_graph) +{ + return general_datum_to_syntax(o, ut, scheme_false, scheme_false, can_graph, 0); +} + +/*========================================================================*/ +/* simplify */ +/*========================================================================*/ + +#ifdef DO_STACK_CHECK +static void simplify_syntax_inner(Scheme_Object *o, + Scheme_Hash_Table *rns, + Scheme_Hash_Table *marks); + +static Scheme_Object *simplify_syntax_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Scheme_Object *o = (Scheme_Object *)p->ku.k.p1; + Scheme_Hash_Table *rns = (Scheme_Hash_Table *)p->ku.k.p2; + Scheme_Hash_Table *marks = (Scheme_Hash_Table *)p->ku.k.p3; + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + + simplify_syntax_inner(o, rns, marks); + + return NULL; +} +#endif + +static void simplify_syntax_inner(Scheme_Object *o, + Scheme_Hash_Table *rns, + Scheme_Hash_Table *marks) +{ + Scheme_Stx *stx = (Scheme_Stx *)o; + Scheme_Object *v; + +#ifdef DO_STACK_CHECK + { +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + p->ku.k.p1 = (void *)o; + p->ku.k.p2 = (void *)rns; + p->ku.k.p3 = (void *)marks; + scheme_handle_stack_overflow(simplify_syntax_k); + return; + } + } +#endif + SCHEME_USE_FUEL(1); + + /* Propagate wraps: */ + scheme_stx_content((Scheme_Object *)stx); + + if (rns) { + v = wraps_to_datum(stx->val, stx->wraps, NULL, rns, 1); + stx->wraps = v; + } + + if (stx->certs && !marks) + marks = scheme_make_hash_table(SCHEME_hash_ptr); + + v = stx->val; + + if (SCHEME_PAIRP(v)) { + while (SCHEME_PAIRP(v)) { + simplify_syntax_inner(SCHEME_CAR(v), rns, marks); + v = SCHEME_CDR(v); + } + if (!SCHEME_NULLP(v)) { + simplify_syntax_inner(v, rns, marks); + } + } else if (SCHEME_BOXP(v)) { + simplify_syntax_inner(SCHEME_BOX_VAL(v), rns, marks); + } else if (SCHEME_VECTORP(v)) { + int size = SCHEME_VEC_SIZE(v), i; + + for (i = 0; i < size; i++) { + simplify_syntax_inner(SCHEME_VEC_ELS(v)[i], rns, marks); + } + } else if (SCHEME_HASHTRP(v)) { + Scheme_Hash_Tree *ht = (Scheme_Hash_Tree *)v; + Scheme_Object *key, *val; + int i; + + i = scheme_hash_tree_next(ht, -1); + while (i != -1) { + scheme_hash_tree_index(ht, i, &key, &val); + simplify_syntax_inner(val, rns, marks); + i = scheme_hash_tree_next(ht, i); + } + } else if (prefab_p(v)) { + Scheme_Structure *s = (Scheme_Structure *)v; + int size = s->stype->num_slots, i; + + for (i = 0; i < size; i++) { + simplify_syntax_inner(s->slots[i], rns, marks); + } + } + + if (marks) + add_all_marks(stx->wraps, marks); + + /* Pare certs based on marks that are actually used, + and eliminate redundant certs. */ + if (stx->certs) { + Scheme_Cert *orig_certs, *certs, *cl, *all_used_after, *result; + int i; + for (i = 0; i < 2; i++) { + if (!i) + certs = ACTIVE_CERTS(stx); + else + certs = INACTIVE_CERTS(stx); + orig_certs = certs; + /* Is there a tail where all certs are used? */ + all_used_after = certs; + for (cl = certs; cl; cl = cl->next) { + if (!scheme_hash_get(marks, cl->mark)) + all_used_after = cl->next; + } + /* In the all-used tail, are any redundant? */ + for (cl = all_used_after; cl; cl = cl->next) { + v = scheme_hash_get(marks, cl->mark); + if (SCHEME_VOIDP(v)) { + /* Reset marks, because we're giving up on all_used_after */ + result = cl; + for (cl = all_used_after; cl != result; cl = cl->next) { + scheme_hash_set(marks, cl->mark, scheme_true); + } + all_used_after = NULL; + break; + } + scheme_hash_set(marks, cl->mark, scheme_void); + } + /* If any marks are unused or redundant, then all_used_after will + have been changed. Also, every mark in all_used_after is mapped + to void instead of true in the marks hash table. */ + if (all_used_after != certs) { + /* We can simplify... */ + result = all_used_after; + for (cl = orig_certs; cl; cl = cl->next) { + if (SAME_OBJ(cl, all_used_after)) + break; + if (scheme_hash_get(marks, cl->mark)) { + v = scheme_hash_get(marks, cl->mark); + if (!SCHEME_VOIDP(v)) + result = cons_cert(cl->mark, cl->modidx, cl->insp, cl->key, result); + } + } + if (!i) { + if (SCHEME_RPAIRP(stx->certs)) { + Scheme_Object *pr; + pr = scheme_make_raw_pair((Scheme_Object *)result, SCHEME_CDR(stx->certs)); + stx->certs = pr; + } else + stx->certs = (Scheme_Object *)result; + } else { + if (!result) + stx->certs = SCHEME_CAR(stx->certs); + else { + Scheme_Object *pr; + pr = scheme_make_raw_pair(SCHEME_CAR(stx->certs), (Scheme_Object *)result); + stx->certs = pr; + } + } + } + /* Reset mark map from void to true: */ + for (cl = all_used_after; cl; cl = cl->next) { + scheme_hash_set(marks, cl->mark, scheme_true); + } + } + } +} + +Scheme_Object *scheme_new_stx_simplify_cache() +{ + return (Scheme_Object *)scheme_make_hash_table(SCHEME_hash_ptr); +} + +void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) +{ +#if 0 + if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { + fprintf(stderr, + "simplifying... %s\n", + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), + NULL)); + explain_simp = 1; + } +#endif + + if (cache) { + Scheme_Hash_Table *rns; + + rns = (Scheme_Hash_Table *)cache; + + simplify_syntax_inner(stx, rns, NULL); + } + +#if 0 + if (explain_simp) { + explain_simp = 0; + fprintf(stderr, "simplified: %s\n", + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), + NULL)); + } +#endif +} + +/*========================================================================*/ +/* Scheme functions and helpers */ +/*========================================================================*/ + +static Scheme_Object *syntax_p(int argc, Scheme_Object **argv) +{ + return SCHEME_STXP(argv[0]) ? scheme_true : scheme_false; +} + +static Scheme_Object *syntax_to_datum(int argc, Scheme_Object **argv) +{ + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax->datum", "syntax", 0, argc, argv); + + return scheme_syntax_to_datum(argv[0], 0, NULL); +} + +static int nonneg_exact_or_false_p(Scheme_Object *o) +{ + return SCHEME_FALSEP(o) || scheme_nonneg_exact_p(o); +} + +static int pos_exact_or_false_p(Scheme_Object *o) +{ + return (SCHEME_FALSEP(o) + || (SCHEME_INTP(o) && (SCHEME_INT_VAL(o) > 0)) + || (SCHEME_BIGNUMP(o) && SCHEME_BIGPOS(o))); +} + +static Scheme_Object *datum_to_syntax(int argc, Scheme_Object **argv) +{ + Scheme_Object *src = scheme_false, *properties = NULL, *certs = NULL; + + if (!SCHEME_FALSEP(argv[0]) && !SCHEME_STXP(argv[0])) + scheme_wrong_type("datum->syntax", "syntax or #f", 0, argc, argv); + if (argc > 2) { + int ll; + + src = argv[2]; + + ll = scheme_proper_list_length(src); + + if (SCHEME_CHAPERONEP(src)) { + src = SCHEME_CHAPERONE_VAL(src); + if (SCHEME_VECTORP(src) && (SCHEME_VEC_SIZE(src) == 5)) { + Scheme_Object *a; + int i; + src = scheme_make_vector(5, NULL); + for (i = 0; i < 5; i++) { + a = scheme_chaperone_vector_ref(argv[2], i); + SCHEME_VEC_ELS(src)[i] = a; + } + } + } + + if (!SCHEME_FALSEP(src) + && !SCHEME_STXP(src) + && !(SCHEME_VECTORP(src) + && (SCHEME_VEC_SIZE(src) == 5) + && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[1]) + && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[2]) + && pos_exact_or_false_p(SCHEME_VEC_ELS(src)[3]) + && nonneg_exact_or_false_p(SCHEME_VEC_ELS(src)[4])) + && !((ll == 5) + && pos_exact_or_false_p(SCHEME_CADR(src)) + && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(src))) + && pos_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src)))) + && nonneg_exact_or_false_p(SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src))))))) + scheme_wrong_type("datum->syntax", "syntax, source location vector or list, or #f", 2, argc, argv); + + if (SCHEME_VECTORP(src)) + ll = 5; + + if (argc > 3) { + if (!SCHEME_FALSEP(argv[3])) { + if (!SCHEME_STXP(argv[3])) + scheme_wrong_type("datum->syntax", "syntax or #f", 3, argc, argv); + properties = ((Scheme_Stx *)argv[3])->props; + } + + if (argc > 4) { + if (!SCHEME_FALSEP(argv[4])) { + if (!SCHEME_STXP(argv[4])) + scheme_wrong_type("datum->syntax", "syntax or #f", 4, argc, argv); + certs = (Scheme_Object *)INACTIVE_CERTS((Scheme_Stx *)argv[4]); + } + } + } + + if (ll == 5) { + /* line--column--pos--span format */ + Scheme_Object *line, *col, *pos, *span; + if (SCHEME_VECTORP(src)) { + line = SCHEME_VEC_ELS(src)[1]; + col = SCHEME_VEC_ELS(src)[2]; + pos = SCHEME_VEC_ELS(src)[3]; + span = SCHEME_VEC_ELS(src)[4]; + src = SCHEME_VEC_ELS(src)[0]; + } else { + line = SCHEME_CADR(src); + col = SCHEME_CADR(SCHEME_CDR(src)); + pos = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(src))); + span = SCHEME_CADR(SCHEME_CDR(SCHEME_CDR(SCHEME_CDR(src)))); + src = SCHEME_CAR(src); + } + + if (SCHEME_FALSEP(line) != SCHEME_FALSEP(col)) + scheme_arg_mismatch("datum->syntax", + "line and column positions must both be numbers or #f in: ", + argv[2]); + + /* Too-large positions go to unknown */ + if (SCHEME_BIGNUMP(line) || SCHEME_BIGNUMP(col)) { + line = scheme_make_integer(-1); + col = scheme_make_integer(-1); + } + if (SCHEME_BIGNUMP(pos)) + pos = scheme_make_integer(-1); + if (span && SCHEME_BIGNUMP(span)) + span = scheme_make_integer(-1); + + src = scheme_make_stx_w_offset(scheme_false, + SCHEME_FALSEP(line) ? -1 : SCHEME_INT_VAL(line), + SCHEME_FALSEP(col) ? -1 : (SCHEME_INT_VAL(col)+1), + SCHEME_FALSEP(pos) ? -1 : SCHEME_INT_VAL(pos), + SCHEME_FALSEP(span) ? -1 : SCHEME_INT_VAL(span), + src, + NULL); + } + } + + if (SCHEME_STXP(argv[1])) + return argv[1]; + + src = scheme_datum_to_syntax(argv[1], src, argv[0], 1, 0); + + if (properties) { + ((Scheme_Stx *)src)->props = properties; + } + + if (certs) + src = add_certs(src, (Scheme_Cert *)certs, NULL, 0); + + return src; +} + + +Scheme_Object *scheme_checked_syntax_e(int argc, Scheme_Object **argv) +{ + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-e", "syntax", 0, argc, argv); + + return scheme_stx_content(argv[0]); +} + +static Scheme_Object *syntax_line(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-line", "syntax", 0, argc, argv); + + if (stx->srcloc->line < 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->line); +} + +static Scheme_Object *syntax_col(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-column", "syntax", 0, argc, argv); + + if (stx->srcloc->col < 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->col-1); +} + +static Scheme_Object *syntax_pos(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-position", "syntax", 0, argc, argv); + + if (stx->srcloc->pos < 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->pos); +} + +static Scheme_Object *syntax_span(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-span", "syntax", 0, argc, argv); + + if (stx->srcloc->span < 0) + return scheme_false; + else + return scheme_make_integer(stx->srcloc->span); +} + +static Scheme_Object *syntax_src(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-source", "syntax", 0, argc, argv); + + return stx->srcloc->src; +} + +static Scheme_Object *syntax_to_list(int argc, Scheme_Object **argv) +{ + Scheme_Object *l; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax->list", "syntax", 0, argc, argv); + + l = scheme_stx_content(argv[0]); + if (SCHEME_NULLP(l)) + return scheme_null; + else if (SCHEME_PAIRP(l)) { + int islist; + l = scheme_flatten_syntax_list(l, &islist); + if (islist) + return l; + else + return scheme_false; + } else + return scheme_false; +} + +static Scheme_Object *syntax_original_p(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx; + WRAP_POS awl; + WRAP_POS ewl; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-original?", "syntax", 0, argc, argv); + + stx = (Scheme_Stx *)argv[0]; + + if (stx->props) { + if (SAME_OBJ(stx->props, STX_SRCTAG)) { + /* Check for marks... */ + } else { + Scheme_Object *e; + + for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { + if (SAME_OBJ(source_symbol, SCHEME_CAR(SCHEME_CAR(e)))) { + break; + } + } + + if (SCHEME_NULLP(e)) + return scheme_false; + } + } else + return scheme_false; + + WRAP_POS_INIT(awl, stx->wraps); + WRAP_POS_INIT_END(ewl); + + if (same_marks(&awl, &ewl, scheme_false)) + return scheme_true; + else + return scheme_false; +} + +Scheme_Object *scheme_stx_property(Scheme_Object *_stx, + Scheme_Object *key, + Scheme_Object *val) +{ + Scheme_Stx *stx; + Scheme_Object *l; + + stx = (Scheme_Stx *)_stx; + + if (stx->props) { + if (SAME_OBJ(stx->props, STX_SRCTAG)) { + if (val) + l = CONS(CONS(source_symbol, scheme_true), + scheme_null); + else + l = NULL; + } else { + Scheme_Object *e; + + for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { + if (SAME_OBJ(key, SCHEME_CAR(SCHEME_CAR(e)))) { + if (val) + break; + else + return SCHEME_CDR(SCHEME_CAR(e)); + } + } + + if (SCHEME_NULLP(e)) + l = stx->props; + else { + /* Remove existing binding: */ + Scheme_Object *first = scheme_null, *last = NULL, *p; + + for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { + if (SAME_OBJ(key, SCHEME_CAR(SCHEME_CAR(e)))) { + p = SCHEME_CDR(e); + e = NULL; + } else { + p = CONS(SCHEME_CAR(e), scheme_null); + } + + if (last) + SCHEME_CDR(last) = p; + else + first = p; + last = p; + + if (!e) + break; + } + + l = first; + } + } + } else + l = scheme_null; + + if (val) { + Scheme_Object *wraps, *modinfo_cache; + Scheme_Object *certs; + intptr_t lazy_prefix; + + l = CONS(CONS(key, val), l); + + wraps = stx->wraps; + if (STX_KEY(stx) & STX_SUBSTX_FLAG) { + modinfo_cache = NULL; + lazy_prefix = stx->u.lazy_prefix; + } else { + modinfo_cache = stx->u.modinfo_cache; + lazy_prefix = 0; + } + certs = stx->certs; + + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, l); + + stx->wraps = wraps; + if (modinfo_cache) + stx->u.modinfo_cache = modinfo_cache; + else + stx->u.lazy_prefix = lazy_prefix; /* same as NULL modinfo if no SUBSTX */ + stx->certs = certs; + + return (Scheme_Object *)stx; + } else + return scheme_false; +} + +static Scheme_Object *syntax_property(int argc, Scheme_Object **argv) +{ + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-property", "syntax", 0, argc, argv); + + return scheme_stx_property(argv[0], + argv[1], + (argc > 2) ? argv[2] : NULL); +} + +static Scheme_Object *syntax_property_keys(int argc, Scheme_Object **argv) +{ + Scheme_Stx *stx; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-property-symbol-keys", "syntax", 0, argc, argv); + + stx = (Scheme_Stx *)argv[0]; + + if (stx->props) { + if (!SAME_OBJ(stx->props, STX_SRCTAG)) { + Scheme_Object *e, *k, *l = scheme_null; + + for (e = stx->props; SCHEME_PAIRP(e); e = SCHEME_CDR(e)) { + k = SCHEME_CAR(SCHEME_CAR(e)); + if (SCHEME_SYMBOLP(k) && !SCHEME_SYM_WEIRDP(k)) + l = scheme_make_pair(k, l); + } + return l; + } + } + + return scheme_null; +} + +#define SCHEME_STX_IDP(o) (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))) + +static Scheme_Object *syntax_track_origin(int argc, Scheme_Object **argv) +{ + Scheme_Object *result, *observer; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-track-origin", "syntax", 0, argc, argv); + if (!SCHEME_STXP(argv[1])) + scheme_wrong_type("syntax-track-origin", "syntax", 1, argc, argv); + if (!SCHEME_STX_IDP(argv[2])) + scheme_wrong_type("syntax-track-origin", "identifier syntax", 2, argc, argv); + + result = scheme_stx_track(argv[0], argv[1], argv[2]); + observer = scheme_get_expand_observe(); + SCHEME_EXPAND_OBSERVE_TRACK_ORIGIN(observer, argv[0], result); + return result; +} + +Scheme_Object *scheme_transfer_srcloc(Scheme_Object *to, Scheme_Object *from) +{ + if (!SAME_OBJ(((Scheme_Stx *)from)->srcloc, empty_srcloc)) { + Scheme_Stx *stx = (Scheme_Stx *)to; + Scheme_Object *wraps, *modinfo_cache; + Scheme_Object *certs; + intptr_t lazy_prefix; + + wraps = stx->wraps; + if (STX_KEY(stx) & STX_SUBSTX_FLAG) { + modinfo_cache = NULL; + lazy_prefix = stx->u.lazy_prefix; + } else { + modinfo_cache = stx->u.modinfo_cache; + lazy_prefix = 0; + } + certs = stx->certs; + + stx = (Scheme_Stx *)scheme_make_stx(stx->val, + ((Scheme_Stx *)from)->srcloc, + stx->props); + + stx->wraps = wraps; + if (modinfo_cache) + stx->u.modinfo_cache = modinfo_cache; + else + stx->u.lazy_prefix = lazy_prefix; /* same as NULL modinfo if no SUBSTX */ + stx->certs = certs; + + return (Scheme_Object *)stx; + } else + return to; +} + +static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], Scheme_Object *p) +{ + Scheme_Object *r, *delta; + + r = argv[0]; + + if (!SCHEME_STXP(r)) + scheme_wrong_type("delta-introducer", "syntax", 0, argc, argv); + + delta = SCHEME_PRIM_CLOSURE_ELS(p)[0]; + + for(; !SCHEME_NULLP(delta); delta = SCHEME_CDR(delta)) { + r = scheme_add_remove_mark(r, SCHEME_CAR(delta)); + } + + return r; +} + +static Scheme_Object *extract_phase(const char *who, int pos, int argc, Scheme_Object **argv, + Scheme_Object *delta, int use_shift) +{ + Scheme_Object *phase; + + if (argc > pos) { + phase = argv[pos]; + if (!SCHEME_FALSEP(phase) + && !SCHEME_INTP(phase) + && !SCHEME_BIGNUMP(phase)) + scheme_wrong_type(who, "exact integer or #f", pos, argc, argv); + } else { + Scheme_Thread *p = scheme_current_thread; + intptr_t ph; + ph = (p->current_local_env + ? p->current_local_env->genv->phase + : (use_shift + ? p->current_phase_shift + : 0)); + phase = scheme_make_integer(ph); + + if (SCHEME_FALSEP(delta) || SCHEME_FALSEP(phase)) + phase = scheme_false; + else + phase = scheme_bin_plus(delta, phase); + } + + return phase; +} + +Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) +{ + Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1]; + int l1, l2; + Scheme_Object *phase; + + if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0]))) + scheme_wrong_type("make-syntax-delta-introducer", "syntax identifier", 0, argc, argv); + if (!SCHEME_STXP(argv[1]) && !SCHEME_FALSEP(argv[1])) + scheme_wrong_type("make-syntax-delta-introducer", "syntax or #f", 1, argc, argv); + + phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1); + + m1 = scheme_stx_extract_marks(argv[0]); + orig_m1 = m1; + l1 = scheme_list_length(m1); + delta = scheme_null; + if (SCHEME_FALSEP(argv[1])) { + m2 = scheme_false; + } else { + m2 = scheme_stx_extract_marks(argv[1]); + + l2 = scheme_list_length(m2); + + while (l1 > l2) { + delta = CONS(SCHEME_CAR(m1), delta); + m1 = SCHEME_CDR(m1); + l1--; + } + } + + if (!scheme_equal(m1, m2)) { + /* tails don't match, so keep all marks --- except + those that determine a module binding */ + int skipped = -1; + Scheme_Object *mod; + + mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, + scheme_make_hash_table(SCHEME_hash_ptr)); + + if ((skipped == -1) && SCHEME_FALSEP(mod)) { + /* For top-level bindings, need to check the current environment's table, + because the identifier might not have the top level in its renamings. */ + Scheme_Env *env; + + if (scheme_current_thread->current_local_env) + env = scheme_current_thread->current_local_env->genv; + else + env = NULL; + if (!env) env = scheme_get_env(NULL); + if (env) { + scheme_tl_id_sym(env, argv[0], NULL, 0, NULL, &skipped); + } + } + + if (skipped > -1) { + /* Just keep the first `skipped' marks. */ + delta = scheme_null; + m1 = orig_m1; + while (skipped) { + delta = CONS(SCHEME_CAR(m1), delta); + m1 = SCHEME_CDR(m1); + skipped--; + } + } else { + /* Keep them all */ + while (l1) { + delta = CONS(SCHEME_CAR(m1), delta); + m1 = SCHEME_CDR(m1); + l1--; + } + } + } + + a[0] = delta; + + return scheme_make_prim_closure_w_arity(delta_introducer, 1, a, "delta-introducer", 1, 1); +} + +static Scheme_Object *bound_eq(int argc, Scheme_Object **argv) +{ + Scheme_Object *phase; + + if (!SCHEME_STX_IDP(argv[0])) + scheme_wrong_type("bound-identifier=?", "identifier syntax", 0, argc, argv); + if (!SCHEME_STX_IDP(argv[1])) + scheme_wrong_type("bound-identifier=?", "identifier syntax", 1, argc, argv); + + phase = extract_phase("bound-identifier=?", 2, argc, argv, scheme_make_integer(0), 0); + + return (scheme_stx_bound_eq(argv[0], argv[1], phase) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *do_module_eq(const char *who, int delta, int argc, Scheme_Object **argv) +{ + Scheme_Object *phase; + + if (!SCHEME_STX_IDP(argv[0])) + scheme_wrong_type(who, "identifier syntax", 0, argc, argv); + if (!SCHEME_STX_IDP(argv[1])) + scheme_wrong_type(who, "identifier syntax", 1, argc, argv); + + phase = extract_phase(who, 2, argc, argv, + ((delta == MZ_LABEL_PHASE) + ? scheme_false + : scheme_make_integer(delta)), + 0); + + return (scheme_stx_module_eq2(argv[0], argv[1], phase, NULL) + ? scheme_true + : scheme_false); +} + +static Scheme_Object *module_eq(int argc, Scheme_Object **argv) +{ + return do_module_eq("free-identifier=?", 0, argc, argv); +} + +static Scheme_Object *module_trans_eq(int argc, Scheme_Object **argv) +{ + return do_module_eq("free-transformer-identifier=?", 1, argc, argv); +} + +static Scheme_Object *module_templ_eq(int argc, Scheme_Object **argv) +{ + return do_module_eq("free-template-identifier=?", -1, argc, argv); +} + +static Scheme_Object *module_label_eq(int argc, Scheme_Object **argv) +{ + return do_module_eq("free-label-identifier=?", MZ_LABEL_PHASE, argc, argv); +} + +static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **argv, Scheme_Object *dphase) +{ + Scheme_Object *a, *m, *nom_mod, *nom_a, *phase; + Scheme_Object *src_phase_index, *mod_phase, *nominal_src_phase; + + a = argv[0]; + + if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) + scheme_wrong_type(name, "identifier syntax", 0, argc, argv); + + phase = extract_phase(name, 1, argc, argv, dphase, 1); + + if (argc > 1) { + phase = argv[1]; + if (!SCHEME_FALSEP(phase) + && !SCHEME_INTP(phase) + && !SCHEME_BIGNUMP(phase)) + scheme_wrong_type(name, "exact integer or #f", 1, argc, argv); + } else { + Scheme_Thread *p = scheme_current_thread; + phase = scheme_make_integer(p->current_local_env + ? p->current_local_env->genv->phase + : p->current_phase_shift); + if (SCHEME_FALSEP(dphase) || SCHEME_FALSEP(phase)) + phase = scheme_false; + else + phase = scheme_bin_plus(dphase, phase); + } + + m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr), + &a, + phase, + &nom_mod, &nom_a, + &mod_phase, + &src_phase_index, + &nominal_src_phase, + NULL, + NULL, + NULL); + + if (!m) + return scheme_false; + else if (SAME_OBJ(m, scheme_undefined)) { + return lexical_symbol; + } else + return CONS(m, CONS(a, CONS(nom_mod, + CONS(nom_a, + CONS(mod_phase, + CONS(src_phase_index, + CONS(nominal_src_phase, + scheme_null))))))); +} + +static Scheme_Object *module_binding(int argc, Scheme_Object **argv) +{ + return do_module_binding("identifier-binding", argc, argv, scheme_make_integer(0)); +} + +static Scheme_Object *module_trans_binding(int argc, Scheme_Object **argv) +{ + return do_module_binding("identifier-transformer-binding", argc, argv, scheme_make_integer(1)); +} + +static Scheme_Object *module_templ_binding(int argc, Scheme_Object **argv) +{ + return do_module_binding("identifier-template-binding", argc, argv, scheme_make_integer(-1)); +} + +static Scheme_Object *module_label_binding(int argc, Scheme_Object **argv) +{ + return do_module_binding("identifier-label-binding", argc, argv, scheme_false); +} + +static Scheme_Object *identifier_prune(int argc, Scheme_Object **argv) +{ + Scheme_Object *a = argv[0], *p, *l; + + if (!SCHEME_STXP(a) || !SCHEME_STX_SYMBOLP(a)) + scheme_wrong_type("identifier-prune-lexical-context", "identifier syntax", 0, argc, argv); + + if (argc > 1) { + l = argv[1]; + while (SCHEME_PAIRP(l)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(l))) + break; + l = SCHEME_CDR(l); + } + if (!SCHEME_NULLP(l)) + scheme_wrong_type("identifier-prune-lexical-context", "list of symbols", 1, argc, argv); + l = argv[1]; + } else { + l = scheme_make_pair(SCHEME_STX_VAL(a), scheme_null); + } + + p = make_prune_context(l); + + return scheme_add_rename(a, p); +} + +static Scheme_Object *identifier_prune_to_module(int argc, Scheme_Object **argv) +{ + WRAP_POS w; + Scheme_Stx *stx = (Scheme_Stx *)argv[0]; + Scheme_Object *l = scheme_null; + + if (!SCHEME_STXP(argv[0]) || !SCHEME_STX_SYMBOLP(argv[0])) + scheme_wrong_type("identifier-prune-to-source-module", "identifier syntax", 0, argc, argv); + + /* Keep only redirecting phase shifts */ + + WRAP_POS_INIT(w, ((Scheme_Stx *)stx)->wraps); + while (!WRAP_POS_END_P(w)) { + if (SCHEME_BOXP(WRAP_POS_FIRST(w))) { + /* Phase shift: */ + Scheme_Object *vec, *dest, *src; + + vec = SCHEME_PTR_VAL(WRAP_POS_FIRST(w)); + + src = SCHEME_VEC_ELS(vec)[1]; + dest = SCHEME_VEC_ELS(vec)[2]; + + /* If src is #f, shift is just for phase; no redirection */ + if (!SCHEME_FALSEP(src)) { + l = scheme_make_pair(WRAP_POS_FIRST(w), l); + } + } + + WRAP_POS_INC(w); + } + + l = scheme_reverse(l); + + stx = (Scheme_Stx *)scheme_make_stx(stx->val, stx->srcloc, stx->props); + stx->wraps = l; + + return (Scheme_Object *)stx; +} + +static Scheme_Object *syntax_src_module(int argc, Scheme_Object **argv) +{ + int source = 0; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-source-module", "syntax", 0, argc, argv); + + if ((argc > 1) && SCHEME_TRUEP(argv[1])) + source = 1; + + return scheme_stx_source_module(argv[0], source, source); +} + +/**********************************************************************/ + +static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv) +{ + Scheme_Object *insp, *key; + + if (!SCHEME_STXP(argv[0])) + scheme_wrong_type("syntax-recertify", "syntax", 0, argc, argv); + if (!SCHEME_STXP(argv[1])) + scheme_wrong_type("syntax-recertify", "syntax", 1, argc, argv); + if (SCHEME_TRUEP(argv[2]) && !SAME_TYPE(SCHEME_TYPE(argv[2]), scheme_inspector_type)) + scheme_wrong_type("syntax-recertify", "inspector or #f", 2, argc, argv); + + if (SAME_OBJ(argv[0], argv[1])) + return argv[0]; + + insp = argv[2]; + if (SCHEME_FALSEP(insp)) + insp = NULL; + key = argv[3]; + + if (((Scheme_Stx *)argv[1])->certs) { + Scheme_Stx *stx, *res; + Scheme_Cert *certs, *new_certs, *orig_certs; + int i; + + stx = (Scheme_Stx *)argv[0]; + + for (i = 0; i < 2; i++) { + if (!i) { + certs = ACTIVE_CERTS((Scheme_Stx *)argv[1]); + new_certs = ACTIVE_CERTS(stx); + } else { + certs = INACTIVE_CERTS((Scheme_Stx *)argv[1]); + new_certs = INACTIVE_CERTS(stx); + } + + orig_certs = new_certs; + + while (certs) { + if (!SAME_OBJ(certs->key, key) + && !SAME_OBJ(certs->insp, insp) + && (!insp || !scheme_is_subinspector(certs->insp, insp))) { + /* Drop opaque certification. */ + } else { + if (!cert_in_chain(certs->mark, certs->key, new_certs)) + new_certs = cons_cert(certs->mark, certs->modidx, certs->insp, certs->key, new_certs); + } + certs = certs->next; + } + + if (!SAME_OBJ(orig_certs, new_certs)) { + if (i && !orig_certs) + stx = (Scheme_Stx *)lift_inactive_certs((Scheme_Object *)stx, 0); + + res = (Scheme_Stx *)scheme_make_stx(stx->val, + stx->srcloc, + stx->props); + res->wraps = stx->wraps; + res->u.lazy_prefix = stx->u.lazy_prefix; + + if (!i && (!stx->certs || !SCHEME_RPAIRP(stx->certs) || !SCHEME_CDR(stx->certs))) + res->certs = (Scheme_Object *)new_certs; + else { + Scheme_Object *pr; + if (!i) + pr = scheme_make_raw_pair((Scheme_Object *)new_certs, SCHEME_CDR(stx->certs)); + else + pr = scheme_make_raw_pair((Scheme_Object *)ACTIVE_CERTS(stx), (Scheme_Object *)new_certs); + res->certs = pr; + } + + stx = res; + } + } + + return (Scheme_Object *)stx; + } else + return argv[0]; +} + +/**********************************************************************/ +/* Debugging */ +/**********************************************************************/ + +static Scheme_Object *explode_cert_chain(Scheme_Cert *c, Scheme_Hash_Table *ht) +{ + Scheme_Object *first = scheme_null, *last = NULL, *pr, *vec; + Scheme_Cert *next; + int depth = c ? c->depth : 0; + + while (c) { + next = c->next; + pr = scheme_hash_get(ht, (Scheme_Object *)c); + if (!pr) { + vec = scheme_make_vector(3, NULL); + SCHEME_VEC_ELS(vec)[0] = c->mark; + SCHEME_VEC_ELS(vec)[1] = (c->modidx ? c->modidx : scheme_false); + SCHEME_VEC_ELS(vec)[2] = (c->key ? c->key : scheme_false); + pr = scheme_make_pair(vec, scheme_null); + scheme_hash_set(ht, (Scheme_Object *)c, pr); + } else + next = NULL; + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + c = next; + } + + if (!SCHEME_NULLP(first)) { + first = scheme_make_pair(scheme_make_integer(depth), first); + } + + return first; +} + +static Scheme_Object *explode_certs(Scheme_Stx *stx, Scheme_Hash_Table *ht) +{ + Scheme_Cert *a, *i; + + a = ACTIVE_CERTS(stx); + i = INACTIVE_CERTS(stx); + + return scheme_make_pair(explode_cert_chain(a, ht), + explode_cert_chain(i, ht)); +} + +static Scheme_Object *explode_wraps(Scheme_Object *wraps, Scheme_Hash_Table *ht) +{ + Scheme_Object *key, *prev_key = NULL, *pr, *first = scheme_null, *last = NULL, *v; + WRAP_POS awl; + + WRAP_POS_INIT(awl, wraps); + + while (!WRAP_POS_END_P(awl)) { + key = WRAP_POS_KEY(awl); + if (key != prev_key) { + pr = scheme_hash_get(ht, key); + if (pr) { + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + break; + } else { + pr = scheme_make_pair(scheme_void, scheme_null); + if (last) + SCHEME_CDR(last) = pr; + else + first = pr; + last = pr; + pr = scheme_make_pair(scheme_false, scheme_null); + scheme_hash_set(ht, key, pr); + } + prev_key = key; + } else { + pr = scheme_make_pair(scheme_false, scheme_null); + } if (last) SCHEME_CDR(last) = pr; else first = pr; last = pr; - var = SCHEME_STX_CDR(var); + v = WRAP_POS_FIRST(awl); + + if (SCHEME_RENAMESP(v)) { + Module_Renames *mrn = (Module_Renames *)v; + Scheme_Object *o; + + v = scheme_hash_get(ht, (Scheme_Object *)mrn); + if (!v) { + v = scheme_make_vector(7, NULL); + o = scheme_intern_symbol("rename:"); + SCHEME_VEC_ELS(v)[0] = o; + SCHEME_VEC_ELS(v)[1] = mrn->phase; + SCHEME_VEC_ELS(v)[2] = (Scheme_Object *)mrn->ht; + SCHEME_VEC_ELS(v)[3] = (mrn->nomarshal_ht ? (Scheme_Object *)mrn->nomarshal_ht : scheme_false); + SCHEME_VEC_ELS(v)[4] = scheme_true; /* mrn->shared_pes; */ + SCHEME_VEC_ELS(v)[5] = (mrn->marked_names ? (Scheme_Object *)mrn->marked_names : scheme_false); + SCHEME_VEC_ELS(v)[6] = (Scheme_Object *)mrn->unmarshal_info; + scheme_hash_set(ht, (Scheme_Object *)mrn, v); + } + } + + SCHEME_CAR(pr) = v; + + WRAP_POS_INC(awl); } return first; } -static Scheme_Object * -define_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) { - Scheme_Object *var, *val, *targets, *variables, *vec; - - scheme_define_parse(form, &var, &val, 0, env, 0); - variables = var; - - targets = defn_targets_syntax(var, env, rec, drec); + Scheme_Object *vec, *v; - scheme_compile_rec_done_local(rec, drec); - if (SCHEME_STX_PAIRP(targets) && SCHEME_STX_NULLP(SCHEME_STX_CDR(targets))) { - var = SCHEME_STX_CAR(variables); - rec[drec].value_name = SCHEME_STX_SYM(var); + if (SCHEME_PAIRP(stx)) { + return scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(stx), ht), + scheme_explode_syntax(SCHEME_CDR(stx), ht)); } + if (SCHEME_NULLP(stx)) + return scheme_null; - env = scheme_no_defines(env); + vec = scheme_hash_get(ht, stx); + if (vec) + return vec; - scheme_rec_add_certs(rec, drec, form); + vec = scheme_make_vector(3, NULL); + scheme_hash_set(ht, stx, vec); - val = scheme_compile_expr(val, env, rec, drec); + v = ((Scheme_Stx *)stx)->val; + if (SCHEME_PAIRP(v)) { + v = scheme_make_pair(scheme_explode_syntax(SCHEME_CAR(v), ht), + scheme_explode_syntax(SCHEME_CDR(v), ht)); + } + SCHEME_VEC_ELS(vec)[0] = v; - vec = scheme_make_vector(2, NULL); - SCHEME_VEC_ELS(vec)[0] = targets; - SCHEME_VEC_ELS(vec)[1] = val; - vec->type = scheme_define_values_type; + v = explode_certs((Scheme_Stx *)stx, ht); + SCHEME_VEC_ELS(vec)[1] = v; + v = explode_wraps(((Scheme_Stx *)stx)->wraps, ht); + SCHEME_VEC_ELS(vec)[2] = v; return vec; } -static Scheme_Object * -define_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *var, *val, *fn, *boundname; - - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_VALUES(erec[drec].observer); - - scheme_define_parse(form, &var, &val, 0, env, 0); - - env = scheme_no_defines(env); - - if (SCHEME_STX_PAIRP(var) && SCHEME_STX_NULLP(SCHEME_STX_CDR(var))) - boundname = SCHEME_STX_CAR(var); - else - boundname = scheme_false; - erec[drec].value_name = boundname; - - scheme_rec_add_certs(erec, drec, form); - - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, - cons(var, - cons(scheme_expand_expr(val, env, erec, drec), - scheme_null))), - form, - form, - 0, 2); -} - -/**********************************************************************/ -/* quote */ /**********************************************************************/ -static Scheme_Object * -quote_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) +static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj) { - Scheme_Object *v, *rest; - - rest = SCHEME_STX_CDR(form); - if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) - scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)"); - - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - - v = SCHEME_STX_CAR(rest); - - if (SCHEME_STXP(v)) - return scheme_syntax_to_datum(v, 0, NULL); - else - return v; -} - -static Scheme_Object * -quote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *rest; - - SCHEME_EXPAND_OBSERVE_PRIM_QUOTE(erec[drec].observer); - - rest = SCHEME_STX_CDR(form); - - if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) - scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)"); - - return form; -} - -/**********************************************************************/ -/* if */ -/**********************************************************************/ - -static void check_if_len(Scheme_Object *form, int len) -{ - if (len != 4) { - if (len == 3) { - scheme_wrong_syntax(NULL, NULL, form, - "bad syntax (must have an \"else\" expression)"); - } else { - bad_form(form, len); - } - } -} - -static Scheme_Object * -if_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - int len, opt; - Scheme_Object *test, *thenp, *elsep, *name, *rest; - Scheme_Compile_Info recs[3]; - - len = check_form(form, form); - check_if_len(form, len); - - name = rec[drec].value_name; - scheme_compile_rec_done_local(rec, drec); - - name = scheme_check_name_property(form, name); - - rest = SCHEME_STX_CDR(form); - test = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - thenp = SCHEME_STX_CAR(rest); - if (len == 4) { - rest = SCHEME_STX_CDR(rest); - elsep = SCHEME_STX_CAR(rest); - } else - elsep = scheme_compiled_void(); - - scheme_rec_add_certs(rec, drec, form); - - scheme_init_compile_recs(rec, drec, recs, 3); - recs[1].value_name = name; - recs[2].value_name = name; - - env = scheme_no_defines(env); - - test = scheme_compile_expr(test, env, recs, 0); - - if (SCHEME_TYPE(test) > _scheme_compiled_values_types_) { - opt = 1; - - if (SCHEME_FALSEP(test)) { - /* compile other branch only to get syntax checking: */ - recs[2].dont_mark_local_use = 1; - scheme_compile_expr(thenp, env, recs, 2); - - if (len == 4) - test = scheme_compile_expr(elsep, env, recs, 1); - else - test = elsep; - } else { - if (len == 4) { - /* compile other branch only to get syntax checking: */ - recs[2].dont_mark_local_use = 1; - scheme_compile_expr(elsep, env, recs, 2); - } - - test = scheme_compile_expr(thenp, env, recs, 1); - } - } else { - opt = 0; - thenp = scheme_compile_expr(thenp, env, recs, 1); - if (len == 4) - elsep = scheme_compile_expr(elsep, env, recs, 2); - } - - scheme_merge_compile_recs(rec, drec, recs, (opt || (len == 3)) ? 2 : 3); - - if (opt) - return test; - else - return scheme_make_branch(test, thenp, elsep); -} - -static Scheme_Object * -if_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *test, *rest, *thenp, *elsep, *fn, *boundname; - int len; - Scheme_Expand_Info recs[3]; - - SCHEME_EXPAND_OBSERVE_PRIM_IF(erec[drec].observer); - - len = check_form(form, form); - - check_if_len(form, len); - - if (len == 3) { - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer); - } - - env = scheme_no_defines(env); - - boundname = scheme_check_name_property(form, erec[drec].value_name); - - scheme_rec_add_certs(erec, drec, form); - - scheme_init_expand_recs(erec, drec, recs, 3); - recs[0].value_name = scheme_false; - recs[1].value_name = boundname; - recs[2].value_name = boundname; - - rest = SCHEME_STX_CDR(form); - test = SCHEME_STX_CAR(rest); - test = scheme_expand_expr(test, env, recs, 0); - - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - rest = SCHEME_STX_CDR(rest); - thenp = SCHEME_STX_CAR(rest); - thenp = scheme_expand_expr(thenp, env, recs, 1); - - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) { - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - elsep = SCHEME_STX_CAR(rest); - elsep = scheme_expand_expr(elsep, env, recs, 2); - rest = cons(elsep, scheme_null); - } else { - rest = scheme_null; - } - - rest = cons(thenp, rest); - - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, cons(test, rest)), - form, form, - 0, 2); -} - -/**********************************************************************/ -/* with-continuation-mark */ -/**********************************************************************/ - -static Scheme_Object * -with_cont_mark_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *key, *val, *expr, *name, *orig_form = form; - Scheme_Compile_Info recs[3]; - Scheme_With_Continuation_Mark *wcm; - int len; - len = check_form(form, form); - - if (len != 4) - bad_form(form, len); - - env = scheme_no_defines(env); - - form = SCHEME_STX_CDR(form); - key = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - val = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - expr = SCHEME_STX_CAR(form); - - name = rec[drec].value_name; - scheme_compile_rec_done_local(rec, drec); - - name = scheme_check_name_property(orig_form, name); - - scheme_rec_add_certs(rec, drec, orig_form); - - scheme_init_compile_recs(rec, drec, recs, 3); - recs[2].value_name = name; - - key = scheme_compile_expr(key, env, recs, 0); - val = scheme_compile_expr(val, env, recs, 1); - expr = scheme_compile_expr(expr, env, recs, 2); - - scheme_merge_compile_recs(rec, drec, recs, 3); - - wcm = MALLOC_ONE_TAGGED(Scheme_With_Continuation_Mark); - wcm->so.type = scheme_with_cont_mark_type; - wcm->key = key; - wcm->val = val; - wcm->body = expr; - - return (Scheme_Object *)wcm; -} - -static Scheme_Object * -with_cont_mark_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *key, *val, *expr, *orig_form = form, *fn, *boundname; - int len; - Scheme_Expand_Info recs[3]; - - SCHEME_EXPAND_OBSERVE_PRIM_WCM(erec[drec].observer); - - len = check_form(form, form); - if (len != 4) - bad_form(form, len); - - env = scheme_no_defines(env); - - boundname = scheme_check_name_property(form, erec[drec].value_name); - - scheme_rec_add_certs(erec, drec, form); - - scheme_init_expand_recs(erec, drec, recs, 3); - recs[0].value_name = scheme_false; - recs[1].value_name = scheme_false; - recs[2].value_name = boundname; - - form = SCHEME_STX_CDR(form); - key = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - val = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - expr = SCHEME_STX_CAR(form); - - key = scheme_expand_expr(key, env, recs, 0); - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - val = scheme_expand_expr(val, env, recs, 1); - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - expr = scheme_expand_expr(expr, env, recs, 2); - - fn = SCHEME_STX_CAR(orig_form); - return scheme_datum_to_syntax(cons(fn, - cons(key, - cons(val, - cons(expr, scheme_null)))), - orig_form, - orig_form, - 0, 2); -} - -/**********************************************************************/ -/* set! */ -/**********************************************************************/ - -Scheme_Object * -scheme_set_execute (Scheme_Object *data) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; - Scheme_Object *val; - Scheme_Bucket *var; - Scheme_Prefix *toplevels; - - val = _scheme_eval_linked_expr(sb->val); - - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(sb->var)]; - var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(sb->var)]; - - scheme_set_global_bucket("set!", var, val, sb->set_undef); - - return scheme_void; -} - -Scheme_Object *scheme_set_jit(Scheme_Object *data) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data, *naya; - Scheme_Object *orig_val, *naya_val; - - orig_val = sb->val; - - naya_val = scheme_jit_expr(orig_val); - - if (SAME_OBJ(naya_val, orig_val)) - return data; - else { - naya = MALLOC_ONE_TAGGED(Scheme_Set_Bang); - memcpy(naya, sb, sizeof(Scheme_Set_Bang)); - naya->val = naya_val; - return (Scheme_Object *)naya; - } -} - -void scheme_set_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; - - scheme_validate_expr(port, sb->val, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); - scheme_validate_toplevel(sb->var, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - 0); -} - -Scheme_Object * -scheme_set_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; - Scheme_Object *var, *val; - - var = sb->var; - val = sb->val; - - val = scheme_optimize_expr(val, info, 0); - - info->preserves_marks = 1; - info->single_result = 1; - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { - int pos, delta; - - pos = SCHEME_LOCAL_POS(var); - - /* Register that we use this variable: */ - scheme_optimize_info_lookup(info, pos, NULL, NULL, 0, 0, NULL); - - /* Offset: */ - delta = scheme_optimize_info_get_shift(info, pos); - if (delta) - var = scheme_make_local(scheme_local_type, pos + delta, 0); - - info->vclock++; - } else { - scheme_optimize_info_used_top(info); - } - - sb->var = var; - sb->val = val; - - return (Scheme_Object *)sb; -} - -Scheme_Object * -scheme_set_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data, *naya; - Scheme_Object *var, *val; - - naya = MALLOC_ONE_TAGGED(Scheme_Set_Bang); - memcpy(naya, sb, sizeof(Scheme_Set_Bang)); - - var = naya->var; - val = naya->val; - - val = scheme_optimize_clone(dup_ok, val, info, delta, closure_depth); - if (!val) return NULL; - if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { - var = scheme_optimize_clone(dup_ok, var, info, delta, closure_depth); - if (!var) return NULL; - } - - naya->var = var; - naya->val = val; - - return (Scheme_Object *)naya; -} - -Scheme_Object *scheme_set_shift(Scheme_Object *data, int delta, int after_depth) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; - Scheme_Object *e; - - e = scheme_optimize_shift(sb->var, delta, after_depth); - sb->var = e; - - e = scheme_optimize_shift(sb->val, delta, after_depth); - sb->val = e; - - return (Scheme_Object *)sb; -} - -Scheme_Object * -scheme_set_resolve(Scheme_Object *data, Resolve_Info *rslv) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; - Scheme_Object *var, *val; - - var = sb->var; - val = sb->val; - - val = scheme_resolve_expr(val, rslv); - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type)) { - Scheme_Let_Value *lv; - Scheme_Object *cv; - int flags, li; - - cv = scheme_compiled_void(); - - lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); - lv->iso.so.type = scheme_let_value_type; - lv->body = cv; - lv->count = 1; - li = scheme_resolve_info_lookup(rslv, SCHEME_LOCAL_POS(var), &flags, NULL, 0); - lv->position = li; - SCHEME_LET_AUTOBOX(lv) = (flags & SCHEME_INFO_BOXED); - lv->value = val; - - if (!(flags & SCHEME_INFO_BOXED)) - scheme_signal_error("internal error: set!: set!ed local variable is not boxed"); - - return (Scheme_Object *)lv; - } - - var = scheme_resolve_expr(var, rslv); - - sb->var = var; - sb->val = val; - - return (Scheme_Object *)sb; -} - -Scheme_Object * -scheme_set_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; - Scheme_Object *var, *val; - - var = sb->var; - val = sb->val; - - scheme_sfs_start_sequence(info, 2, 0); - - val = scheme_sfs_expr(val, info, -1); - var = scheme_sfs_expr(var, info, -1); - - sb->var = var; - sb->val = val; - - return (Scheme_Object *)sb; -} - -static Scheme_Object * -set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Set_Bang *sb; - Scheme_Env *menv = NULL; - Scheme_Object *var, *val, *name, *body, *rest, *find_name; - int l, set_undef; - - l = check_form(form, form); - if (l != 3) - bad_form(form, l); - - rest = SCHEME_STX_CDR(form); - name = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - body = SCHEME_STX_CAR(rest); - - scheme_check_identifier("set!", name, NULL, env, form); - - find_name = name; - - scheme_rec_add_certs(rec, drec, form); - - while (1) { - var = scheme_lookup_binding(find_name, env, - SCHEME_SETTING - + SCHEME_GLOB_ALWAYS_REFERENCE - + (rec[drec].dont_mark_local_use - ? SCHEME_DONT_MARK_USE - : 0) - + (rec[drec].resolve_module_ids - ? SCHEME_RESOLVE_MODIDS - : 0), - rec[drec].certs, env->in_modidx, - &menv, NULL, NULL); - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - /* Redirect to a macro? */ - if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1); - - return scheme_compile_expr(form, env, rec, drec); - } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); - find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL, 1); - SCHEME_USE_FUEL(1); - menv = NULL; - } else - break; - } else - break; - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { - scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); - return NULL; - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0); - if (env->genv->module) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; - } - - scheme_compile_rec_done_local(rec, drec); - rec[drec].value_name = SCHEME_STX_SYM(name); - - val = scheme_compile_expr(body, scheme_no_defines(env), rec, drec); - - /* check for (set! x x) */ - if (SAME_TYPE(SCHEME_TYPE(var), SCHEME_TYPE(val))) { - if (SAME_TYPE(SCHEME_TYPE(var), scheme_local_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_local_unbox_type)) { - /* local */ - if (SCHEME_LOCAL_POS(var) == SCHEME_LOCAL_POS(val)) - return scheme_compiled_void(); - } else { - /* global; can't do anything b/c var might be undefined or constant */ - } - } - - set_undef = (rec[drec].comp_flags & COMP_ALLOW_SET_UNDEFINED); - - sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); - sb->so.type = scheme_set_bang_type; - sb->var = var; - sb->val = val; - sb->set_undef = set_undef; - - return (Scheme_Object *)sb; -} - -static Scheme_Object * -set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Env *menv = NULL; - Scheme_Object *name, *var, *fn, *rhs, *find_name, *lexical_binding_id; - int l; - - SCHEME_EXPAND_OBSERVE_PRIM_SET(erec[drec].observer); - - l = check_form(form, form); - if (l != 3) - bad_form(form, l); - - env = scheme_no_defines(env); - - name = SCHEME_STX_CDR(form); - name = SCHEME_STX_CAR(name); - - scheme_check_identifier("set!", name, NULL, env, form); - - find_name = name; - - scheme_rec_add_certs(erec, drec, form); - - while (1) { - /* Make sure it's mutable, and check for redirects: */ - lexical_binding_id = NULL; - var = scheme_lookup_binding(find_name, env, SCHEME_SETTING, - erec[drec].certs, env->in_modidx, - &menv, NULL, &lexical_binding_id); - - SCHEME_EXPAND_OBSERVE_RESOLVE(erec[drec].observer, find_name); - - if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { - /* Redirect to a macro? */ - if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { - - SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form); - - form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, erec, drec, 1); - - SCHEME_EXPAND_OBSERVE_EXIT_MACRO(erec[drec].observer, form); - - if (erec[drec].depth > 0) - erec[drec].depth--; - - erec[drec].value_name = name; - - return scheme_expand_expr(form, env, erec, drec); - } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { - Scheme_Object *new_name; - new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); - new_name = scheme_stx_track(new_name, find_name, find_name); - new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); - find_name = new_name; - menv = NULL; - } else - break; - } else { - if (lexical_binding_id) { - find_name = lexical_binding_id; - } - break; - } - } - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_syntax_compiler_type)) { - scheme_wrong_syntax(NULL, name, form, "cannot mutate syntax identifier"); - } - - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - - - fn = SCHEME_STX_CAR(form); - rhs = SCHEME_STX_CDR(form); - rhs = SCHEME_STX_CDR(rhs); - rhs = SCHEME_STX_CAR(rhs); - - erec[drec].value_name = name; - - rhs = scheme_expand_expr(rhs, env, erec, drec); - - return scheme_datum_to_syntax(cons(fn, - cons(find_name, - cons(rhs, scheme_null))), - form, - form, - 0, 2); -} - -/**********************************************************************/ -/* #%variable-reference */ -/**********************************************************************/ - -Scheme_Object * -scheme_ref_execute (Scheme_Object *data) -{ - Scheme_Prefix *toplevels; - Scheme_Object *o; - Scheme_Bucket *var; - Scheme_Object *tl = SCHEME_PTR1_VAL(data); - Scheme_Env *env; - - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(tl)]; - var = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(tl)]; - env = scheme_environment_from_dummy(SCHEME_CDR(data)); - - o = scheme_alloc_object(); - o->type = scheme_global_ref_type; - SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; - SCHEME_PTR2_VAL(o) = (Scheme_Object *)env; - - return o; -} - -Scheme_Object *scheme_ref_jit(Scheme_Object *data) -{ - return data; -} - -void scheme_ref_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - scheme_validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - 0); - scheme_validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - 0); -} - -Scheme_Object * -scheme_ref_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - scheme_optimize_info_used_top(info); - - info->preserves_marks = 1; - info->single_result = 1; - info->size++; - - return data; -} - -Scheme_Object * -scheme_ref_shift(Scheme_Object *data, int delta, int after_depth) -{ - Scheme_Object *v; - - v = scheme_optimize_shift(SCHEME_PTR1_VAL(data), delta, after_depth); - SCHEME_PTR1_VAL(data) = v; - - v = scheme_optimize_shift(SCHEME_PTR2_VAL(data), delta, after_depth); - SCHEME_PTR2_VAL(data) = v; - - return data; -} - -Scheme_Object * -scheme_ref_resolve(Scheme_Object *data, Resolve_Info *rslv) -{ - Scheme_Object *v; - - v = scheme_resolve_expr(SCHEME_PTR1_VAL(data), rslv); - SCHEME_PTR1_VAL(data) = v; - v = scheme_resolve_expr(SCHEME_PTR2_VAL(data), rslv); - SCHEME_PTR2_VAL(data) = v; - - return data; -} - -Scheme_Object * -scheme_ref_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *a_naya; - Scheme_Object *b_naya; - - scheme_sfs_start_sequence(info, 1, 0); - a_naya = scheme_sfs_expr(SCHEME_PTR1_VAL(data), info, -1); - b_naya = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); - SCHEME_PTR1_VAL(data) = a_naya; - SCHEME_PTR2_VAL(data) = b_naya; - - return data; -} - -static Scheme_Object * -ref_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Env *menv = NULL; - Scheme_Object *var, *name, *rest, *dummy; - int l, ok; - - l = check_form(form, form); - - /* retaining `dummy' ensures that the environment stays - linked from the actual variable */ - if (rec[drec].comp) - dummy = scheme_make_environment_dummy(env); - else - dummy = NULL; - - if (l == 1) { - if (rec[drec].comp) - var = dummy; - else - var = scheme_void; - } else { - if (l != 2) - bad_form(form, l); - - rest = SCHEME_STX_CDR(form); - name = SCHEME_STX_CAR(rest); - - if (SCHEME_STX_PAIRP(name)) { - rest = SCHEME_STX_CAR(name); - if (env->genv->phase == 0) { - var = scheme_top_stx; - } else { - var = scheme_datum_to_syntax(SCHEME_STX_VAL(scheme_top_stx), scheme_false, scheme_sys_wraps(env), 0, 0); - } - ok = scheme_stx_module_eq(rest, var, env->genv->phase); - } else - ok = SCHEME_STX_SYMBOLP(name); - - if (!ok) { - scheme_wrong_syntax("#%variable-reference", name, - form, - "not an identifier or #%%top form"); - return NULL; - } - - if (SCHEME_STX_PAIRP(name)) { - /* FIXME: when using #%top, need to set mutated flag */ - if (rec[drec].comp) - var = scheme_compile_expr(name, env, rec, drec); - else - var = scheme_expand_expr(name, env, rec, drec); - } else { - scheme_rec_add_certs(rec, drec, form); - - var = scheme_lookup_binding(name, env, - SCHEME_REFERENCING - + SCHEME_GLOB_ALWAYS_REFERENCE - + (rec[drec].dont_mark_local_use - ? SCHEME_DONT_MARK_USE - : 0) - + (rec[drec].resolve_module_ids - ? SCHEME_RESOLVE_MODIDS - : 0), - rec[drec].certs, env->in_modidx, - &menv, NULL, NULL); - - if (SAME_TYPE(SCHEME_TYPE(var), scheme_variable_type) - || SAME_TYPE(SCHEME_TYPE(var), scheme_module_variable_type)) { - int imported = 0; - imported = scheme_is_imported(var, env); - - if (rec[drec].comp) { - var = scheme_register_toplevel_in_prefix(var, env, rec, drec, 0); - if (!imported && env->genv->module) - SCHEME_TOPLEVEL_FLAGS(var) |= SCHEME_TOPLEVEL_MUTATED; - } - } else { - scheme_wrong_syntax(NULL, name, form, "identifier does not refer to a top-level or module variable"); - } - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); - } - } - - if (rec[drec].comp) { - Scheme_Object *o; - o = scheme_alloc_object(); - o->type = scheme_varref_form_type; - SCHEME_PTR1_VAL(o) = (Scheme_Object *)var; - SCHEME_PTR2_VAL(o) = (Scheme_Object *)dummy; - return o; - } else - return scheme_void; -} - -static Scheme_Object * -ref_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_VARREF(erec[drec].observer); - - /* Error checking: */ - ref_syntax(form, env, erec, drec); - - /* No change: */ - return form; -} - -/**********************************************************************/ -/* apply-values */ -/**********************************************************************/ - -Scheme_Object *scheme_apply_values_execute(Scheme_Object *data) -{ - Scheme_Object *f, *v; - - f = SCHEME_PTR1_VAL(data); - - f = _scheme_eval_linked_expr(f); - if (!SCHEME_PROCP(f)) { - Scheme_Object *a[1]; - a[0] = f; - scheme_wrong_type("call-with-values", "procedure", -1, 1, a); - return NULL; - } - - v = _scheme_eval_linked_expr_multi(SCHEME_PTR2_VAL(data)); - if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { - Scheme_Thread *p = scheme_current_thread; - int num_rands = p->ku.multiple.count; - - if (num_rands > p->tail_buffer_size) { - /* scheme_tail_apply will allocate */ - if (SAME_OBJ(p->ku.multiple.array, p->values_buffer)) - p->values_buffer = NULL; - } - return scheme_tail_apply(f, num_rands, p->ku.multiple.array); - } else { - Scheme_Object *a[1]; - a[0] = v; - return scheme_tail_apply(f, 1, a); - } -} - -Scheme_Object *scheme_apply_values_jit(Scheme_Object *data) -{ - Scheme_Object *f, *e; - - f = scheme_jit_expr(SCHEME_PTR1_VAL(data)); - e = scheme_jit_expr(SCHEME_PTR2_VAL(data)); - - if (SAME_OBJ(f, SCHEME_PTR1_VAL(data)) - && SAME_OBJ(e, SCHEME_PTR2_VAL(data))) - return data; - else { - data = scheme_alloc_object(); - data->type = scheme_apply_values_type; - SCHEME_PTR1_VAL(data) = f; - SCHEME_PTR2_VAL(data) = e; - return data; - } -} - -Scheme_Object * -scheme_apply_values_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - Scheme_Object *f, *e; - - f = SCHEME_PTR1_VAL(data); - e = SCHEME_PTR2_VAL(data); - - f = scheme_optimize_expr(f, info, 0); - e = scheme_optimize_expr(e, info, 0); - - info->size += 1; - info->vclock += 1; - - return scheme_optimize_apply_values(f, e, info, info->single_result, context); -} - -Scheme_Object * -scheme_apply_values_resolve(Scheme_Object *data, Resolve_Info *rslv) -{ - Scheme_Object *f, *e; - - f = SCHEME_PTR1_VAL(data); - e = SCHEME_PTR2_VAL(data); - - f = scheme_resolve_expr(f, rslv); - e = scheme_resolve_expr(e, rslv); - - SCHEME_PTR1_VAL(data) = f; - SCHEME_PTR2_VAL(data) = e; - - return data; -} - -Scheme_Object * -scheme_apply_values_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *f, *e; - - f = SCHEME_PTR1_VAL(data); - e = SCHEME_PTR2_VAL(data); - - scheme_sfs_start_sequence(info, 2, 0); - - f = scheme_sfs_expr(f, info, -1); - e = scheme_sfs_expr(e, info, -1); - - SCHEME_PTR1_VAL(data) = f; - SCHEME_PTR2_VAL(data) = e; - - return data; -} - -Scheme_Object * -scheme_apply_values_shift(Scheme_Object *data, int delta, int after_depth) -{ - Scheme_Object *e; - - e = scheme_optimize_shift(SCHEME_PTR1_VAL(data), delta, after_depth); - SCHEME_PTR1_VAL(data) = e; - - e = scheme_optimize_shift(SCHEME_PTR2_VAL(data), delta, after_depth); - SCHEME_PTR2_VAL(data) = e; - - return data; -} - -Scheme_Object * -scheme_apply_values_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) -{ - Scheme_Object *f, *e; - - f = SCHEME_PTR1_VAL(data); - e = SCHEME_PTR2_VAL(data); - - f = scheme_optimize_clone(dup_ok, f, info, delta, closure_depth); - if (!f) return NULL; - e = scheme_optimize_clone(dup_ok, e, info, delta, closure_depth); - if (!e) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_apply_values_type; - SCHEME_PTR1_VAL(data) = f; - SCHEME_PTR2_VAL(data) = e; - - return data; -} - -void scheme_apply_values_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - Scheme_Object *f, *e; - - f = SCHEME_PTR1_VAL(data); - e = SCHEME_PTR2_VAL(data); - - scheme_validate_expr(port, f, stack, tls, - depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); - scheme_validate_expr(port, e, stack, tls, - depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); -} - -/**********************************************************************/ -/* case-lambda */ -/**********************************************************************/ - -Scheme_Object * -scheme_case_lambda_execute(Scheme_Object *expr) -{ - Scheme_Case_Lambda *seqin, *seqout; - int i, cnt; - Scheme_Thread *p = scheme_current_thread; - - seqin = (Scheme_Case_Lambda *)expr; - -#ifdef MZ_USE_JIT - if (seqin->native_code) { - Scheme_Native_Closure_Data *ndata; - Scheme_Native_Closure *nc, *na; - Scheme_Closure_Data *data; - Scheme_Object *val; - GC_CAN_IGNORE Scheme_Object **runstack; - GC_CAN_IGNORE mzshort *map; - int j, jcnt; - - ndata = seqin->native_code; - nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata); - - cnt = seqin->count; - for (i = 0; i < cnt; i++) { - val = seqin->array[i]; - if (!SCHEME_PROCP(val)) { - data = (Scheme_Closure_Data *)val; - na = (Scheme_Native_Closure *)scheme_make_native_closure(data->u.native_code); - runstack = MZ_RUNSTACK; - jcnt = data->closure_size; - map = data->closure_map; - for (j = 0; j < jcnt; j++) { - na->vals[j] = runstack[map[j]]; - } - val = (Scheme_Object *)na; - } - nc->vals[i] = val; - } - - return (Scheme_Object *)nc; - } -#endif - - seqout = (Scheme_Case_Lambda *) - scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) - + (seqin->count - 1) * sizeof(Scheme_Object *)); - seqout->so.type = scheme_case_closure_type; - seqout->count = seqin->count; - seqout->name = seqin->name; - - cnt = seqin->count; - for (i = 0; i < cnt; i++) { - if (SAME_TYPE(SCHEME_TYPE(seqin->array[i]), scheme_closure_type)) { - /* An empty closure, created at compile time */ - seqout->array[i] = seqin->array[i]; - } else { - Scheme_Object *lc; - lc = scheme_make_closure(p, seqin->array[i], 1); - seqout->array[i] = lc; - } - } - - return (Scheme_Object *)seqout; -} - -Scheme_Object *scheme_case_lambda_jit(Scheme_Object *expr) -{ -#ifdef MZ_USE_JIT - Scheme_Case_Lambda *seqin = (Scheme_Case_Lambda *)expr; - - if (!seqin->native_code) { - Scheme_Case_Lambda *seqout; - Scheme_Native_Closure_Data *ndata; - Scheme_Object *val, *name; - int i, cnt, size, all_closed = 1; - - cnt = seqin->count; - - size = sizeof(Scheme_Case_Lambda) + ((cnt - 1) * sizeof(Scheme_Object *)); - - seqout = (Scheme_Case_Lambda *)scheme_malloc_tagged(size); - memcpy(seqout, seqin, size); - - name = seqin->name; - if (name && SCHEME_BOXP(name)) - name = SCHEME_BOX_VAL(name); - - for (i = 0; i < cnt; i++) { - val = seqout->array[i]; - if (SCHEME_PROCP(val)) { - /* Undo creation of empty closure */ - val = (Scheme_Object *)((Scheme_Closure *)val)->code; - seqout->array[i] = val; - } - ((Scheme_Closure_Data *)val)->name = name; - if (((Scheme_Closure_Data *)val)->closure_size) - all_closed = 0; - } - - /* Generating the code may cause empty closures to be formed: */ - ndata = scheme_generate_case_lambda(seqout); - seqout->native_code = ndata; - - if (all_closed) { - /* Native closures do not refer back to the original bytecode, - so no need to worry about clearing the reference. */ - Scheme_Native_Closure *nc; - nc = (Scheme_Native_Closure *)scheme_make_native_case_closure(ndata); - for (i = 0; i < cnt; i++) { - val = seqout->array[i]; - if (!SCHEME_PROCP(val)) { - val = scheme_make_native_closure(((Scheme_Closure_Data *)val)->u.native_code); - } - nc->vals[i] = val; - } - return (Scheme_Object *)nc; - } else { - /* The case-lambda data must point to the original closure-data - record, because that's where the closure maps are kept. But - we don't need the bytecode, anymore. So clone the - closure-data record and drop the bytecode in thte clone. */ - for (i = 0; i < cnt; i++) { - val = seqout->array[i]; - if (!SCHEME_PROCP(val)) { - Scheme_Closure_Data *data; - data = MALLOC_ONE_TAGGED(Scheme_Closure_Data); - memcpy(data, val, sizeof(Scheme_Closure_Data)); - data->code = NULL; - seqout->array[i] = (Scheme_Object *)data; - } - } - } - - return (Scheme_Object *)seqout; - } -#endif - - return expr; -} - -void scheme_case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data; - Scheme_Object *e; + Scheme_Object *vec; int i; - if (!SAME_TYPE(SCHEME_TYPE(data), scheme_case_lambda_sequence_type)) - scheme_ill_formed_code(port); - - for (i = 0; i < seq->count; i++) { - e = seq->array[i]; - if (!SAME_TYPE(SCHEME_TYPE(e), scheme_unclosed_procedure_type) - && !SAME_TYPE(SCHEME_TYPE(e), scheme_closure_type)) - scheme_ill_formed_code(port); - scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, 0, vc, 0, 0, procs); + vec = scheme_make_vector(8, NULL); + for (i = 0; i < 8; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; } -} - -Scheme_Object * -scheme_case_lambda_resolve(Scheme_Object *expr, Resolve_Info *rslv) -{ - int i, all_closed = 1; - Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; - - for (i = 0; i < seq->count; i++) { - Scheme_Object *le; - le = seq->array[i]; - le = scheme_resolve_closure_compilation(le, rslv, 0, 0, 0, NULL); - seq->array[i] = le; - if (!SCHEME_PROCP(le)) - all_closed = 0; - } - - if (all_closed) { - /* Produce closure directly */ - return scheme_case_lambda_execute(expr); - } - - return expr; -} - -Scheme_Object * -scheme_case_lambda_sfs(Scheme_Object *expr, SFS_Info *info) -{ - Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; - Scheme_Object *le, *clears = scheme_null; - int i; - - scheme_sfs_start_sequence(info, seq->count, 0); - - for (i = 0; i < seq->count; i++) { - le = seq->array[i]; - le = scheme_sfs_expr(le, info, -1); - if (SAME_TYPE(SCHEME_TYPE(le), scheme_begin0_sequence_type)) { - /* Some clearing actions were added to the closure. - Lift them out. */ - int j; - Scheme_Sequence *cseq = (Scheme_Sequence *)le; - if (!cseq->count) - scheme_signal_error("internal error: empty sequence"); - for (j = 1; j < cseq->count; j++) { - int pos; - pos = SCHEME_LOCAL_POS(cseq->array[j]); - clears = scheme_make_pair(scheme_make_integer(pos), clears); - } - le = cseq->array[0]; - } - if (!SAME_TYPE(SCHEME_TYPE(le), scheme_unclosed_procedure_type) - && !SAME_TYPE(SCHEME_TYPE(le), scheme_closure_type)) { - scheme_signal_error("internal error: not a lambda for case-lambda: %d", - SCHEME_TYPE(le)); - } - seq->array[i] = le; - } - - if (!SCHEME_NULLP(clears)) { - return scheme_sfs_add_clears(expr, clears, 0); - } else - return expr; -} - -Scheme_Object * -scheme_case_lambda_optimize(Scheme_Object *expr, Optimize_Info *info, int context) -{ - Scheme_Object *le; - int i; - Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)expr; - mzshort **tus, *tu; - int *tu_lens, tup, tu_count = 0; - - if (info->transitive_use_pos) { - /* We'll need to merge transitive_use arrays */ - tup = info->transitive_use_pos - 1; - tus = (mzshort **)MALLOC_N(mzshort*, seq->count); - tu_lens = (int*)MALLOC_N_ATOMIC(int, seq->count); - } else { - tup = 0; - tus = NULL; - tu_lens = NULL; - } - - for (i = 0; i < seq->count; i++) { - le = seq->array[i]; - le = scheme_optimize_expr(le, info, 0); - seq->array[i] = le; - - if (tus) { - tus[i] = info->transitive_use[tup]; - tu_lens[i] = info->transitive_use_len[tup]; - if (tus[i]) { - tu_count += tu_lens[i]; - } - info->transitive_use[tup] = NULL; - info->transitive_use_len[tup] = 0; - } - } - - info->preserves_marks = 1; - info->single_result = 1; - info->size += 1; - - if (tu_count) { - tu = MALLOC_N_ATOMIC(mzshort, tu_count); - tu_count = 0; - for (i = 0; i < seq->count; i++) { - if (tus[i]) { - memcpy(tu + tu_count, tus[i], tu_lens[i] * sizeof(mzshort)); - tu_count += tu_lens[i]; - } - } - info->transitive_use[tup] = tu; - info->transitive_use_len[tup] = tu_count; - } - - return expr; -} - -Scheme_Object * -scheme_case_lambda_clone(int dup_ok, Scheme_Object *data, Optimize_Info *info, int delta, int closure_depth) -{ - Scheme_Object *le; - int i, sz; - Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data; - Scheme_Case_Lambda *seq2; - - sz = sizeof(Scheme_Case_Lambda) + ((seq->count - 1) * sizeof(Scheme_Object*)); - seq2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sz); - memcpy(seq2, seq, sz); - - for (i = 0; i < seq->count; i++) { - le = seq->array[i]; - le = scheme_optimize_clone(dup_ok, le, info, delta, closure_depth); - if (!le) return NULL; - seq2->array[i] = le; - } - - return (Scheme_Object *)seq2; -} - -Scheme_Object * -scheme_case_lambda_shift(Scheme_Object *data, int delta, int after_depth) -{ - Scheme_Object *le; - int i; - Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data; - - for (i = 0; i < seq->count; i++) { - le = seq->array[i]; - le = scheme_optimize_shift(le, delta, after_depth); - seq->array[i] = le; - } - - return data; -} - -Scheme_Object *scheme_unclose_case_lambda(Scheme_Object *expr, int mode) -{ - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)expr; - Scheme_Closure *c; - int i; - - for (i = cl->count; i--; ) { - c = (Scheme_Closure *)cl->array[i]; - if (!ZERO_SIZED_CLOSUREP(c)) { - break; - } - } - - if (i < 0) { - /* We can reconstruct a case-lambda syntactic form. */ - Scheme_Case_Lambda *cl2; - - cl2 = (Scheme_Case_Lambda *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) - + ((cl->count - 1) * sizeof(Scheme_Object*))); - - cl2->so.type = scheme_case_lambda_sequence_type; - cl2->count = cl->count; - cl2->name = cl->name; - - for (i = cl->count; i--; ) { - c = (Scheme_Closure *)cl->array[i]; - cl2->array[i] = (Scheme_Object *)c->code; - } - - if (mode == 2) { - /* sfs */ - return (Scheme_Object *)cl2; - } else if (mode == 1) { - /* JIT */ - return scheme_case_lambda_jit((Scheme_Object *)cl2); - } else - return (Scheme_Object *)cl2; - } - - return expr; -} - -static void case_lambda_check_line(Scheme_Object *line, Scheme_Object *form, Scheme_Comp_Env *env) -{ - Scheme_Object *body, *args; - - if (!SCHEME_STX_PAIRP(line)) - scheme_wrong_syntax(NULL, line, form, NULL); - - body = SCHEME_STX_CDR(line); - args = SCHEME_STX_CAR(line); - - lambda_check_args(args, form, env); - - if (!SCHEME_STX_PAIRP(body)) - scheme_wrong_syntax(NULL, line, form, "bad syntax (%s)", - SCHEME_STX_NULLP(body) ? "empty body" : IMPROPER_LIST_FORM); -} - -static Scheme_Object * -case_lambda_syntax (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *list, *last, *c, *orig_form = form, *name; - Scheme_Case_Lambda *cl; - int i, count = 0; - Scheme_Compile_Info *recs; - - form = SCHEME_STX_CDR(form); - - name = scheme_build_closure_name(orig_form, rec, drec); - - if (SCHEME_STX_NULLP(form)) { - /* Case where there are no cases... */ - form = (Scheme_Object *)scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) - - sizeof(Scheme_Object*)); - - form->type = scheme_case_lambda_sequence_type; - ((Scheme_Case_Lambda *)form)->count = 0; - ((Scheme_Case_Lambda *)form)->name = name; - - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - - if (scheme_has_method_property(orig_form)) { - /* See note in schpriv.h about the IS_METHOD hack */ - if (!name) - name = scheme_false; - name = scheme_box(name); - ((Scheme_Case_Lambda *)form)->name = name; - } - - return form; - } - - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, form, orig_form, NULL); - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) { - c = SCHEME_STX_CAR(form); - - case_lambda_check_line(c, orig_form, env); - - c = cons(scheme_datum_to_syntax(lambda_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - c); - c = scheme_datum_to_syntax(c, orig_form, orig_form, 0, 2); - - return lambda_syntax(c, env, rec, drec); - } - - scheme_compile_rec_done_local(rec, drec); - - scheme_rec_add_certs(rec, drec, orig_form); - - list = last = NULL; - while (SCHEME_STX_PAIRP(form)) { - Scheme_Object *clause; - clause = SCHEME_STX_CAR(form); - case_lambda_check_line(clause, orig_form, env); - - c = cons(lambda_symbol, clause); - - c = scheme_datum_to_syntax(c, clause, scheme_sys_wraps(env), 0, 0); - - c = cons(c, scheme_null); - - if (list) - SCHEME_CDR(last) = c; - else - list = c; - - last = c; - form = SCHEME_STX_CDR(form); - - count++; - } - - if (!SCHEME_STX_NULLP(form)) - scheme_wrong_syntax(NULL, form, orig_form, NULL); - - cl = (Scheme_Case_Lambda *) - scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) - + (count - 1) * sizeof(Scheme_Object *)); - cl->so.type = scheme_case_lambda_sequence_type; - cl->count = count; - cl->name = SCHEME_TRUEP(name) ? name : NULL; - - scheme_compile_rec_done_local(rec, drec); - recs = MALLOC_N_RT(Scheme_Compile_Info, count); - scheme_init_compile_recs(rec, drec, recs, count); - - for (i = 0; i < count; i++) { - Scheme_Object *ce; - ce = SCHEME_CAR(list); - ce = scheme_compile_expr(ce, env, recs, i); - cl->array[i] = ce; - list = SCHEME_CDR(list); - } - - scheme_merge_compile_recs(rec, drec, recs, count); - - if (scheme_has_method_property(orig_form)) { - Scheme_Closure_Data *data; - /* Make sure no branch has 0 arguments: */ - for (i = 0; i < count; i++) { - data = (Scheme_Closure_Data *)cl->array[i]; - if (!data->num_params) - break; - } - if (i >= count) { - data = (Scheme_Closure_Data *)cl->array[0]; - SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_IS_METHOD; - } - } - - return (Scheme_Object *)cl; -} - -static Scheme_Object * -case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *first, *last, *args, *body, *c, *new_line, *orig_form = form; - - SCHEME_EXPAND_OBSERVE_PRIM_CASE_LAMBDA(erec[drec].observer); - - first = SCHEME_STX_CAR(form); - first = cons(first, scheme_null); - last = first; - form = SCHEME_STX_CDR(form); - - scheme_rec_add_certs(erec, drec, orig_form); - - while (SCHEME_STX_PAIRP(form)) { - Scheme_Object *line_form; - Scheme_Comp_Env *newenv; - - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - - line_form = SCHEME_STX_CAR(form); - - case_lambda_check_line(line_form, orig_form, env); - - body = SCHEME_STX_CDR(line_form); - args = SCHEME_STX_CAR(line_form); - - body = scheme_datum_to_syntax(body, line_form, line_form, 0, 0); - - newenv = scheme_add_compilation_frame(args, env, 0, erec[drec].certs); - - body = scheme_add_env_renames(body, newenv, env); - args = scheme_add_env_renames(args, newenv, env); - SCHEME_EXPAND_OBSERVE_CASE_LAMBDA_RENAMES(erec[drec].observer, args, body); - - { - Scheme_Expand_Info erec1; - scheme_init_expand_recs(erec, drec, &erec1, 1); - erec1.value_name = scheme_false; - new_line = cons(args, scheme_expand_block(body, newenv, &erec1, 0)); - } - new_line = scheme_datum_to_syntax(new_line, line_form, line_form, 0, 1); - - c = cons(new_line, scheme_null); - - SCHEME_CDR(last) = c; - last = c; - - form = SCHEME_STX_CDR(form); - } - - if (!SCHEME_STX_NULLP(form)) - scheme_wrong_syntax(NULL, form, orig_form, NULL); - - return scheme_datum_to_syntax(first, orig_form, orig_form, 0, 2); -} - -/**********************************************************************/ -/* implicit set!s */ -/**********************************************************************/ - -/* A bangboxenv step is inserted by the compilation of `lambda' and - `let' forms where an argument or bindings is set!ed in the body. */ - -Scheme_Object *scheme_bangboxenv_execute(Scheme_Object *data) -{ - int pos = SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)); - Scheme_Object *bb; - - data = SCHEME_PTR2_VAL(data); - - bb = scheme_make_envunbox(MZ_RUNSTACK[pos]); - MZ_RUNSTACK[pos] = bb; - - return _scheme_tail_eval(data); -} - -Scheme_Object *scheme_bangboxenv_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *e; - int spos, drop; - - spos = SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)) + info->stackpos; - if (info->pass - && (info->max_used[spos] < info->ip)) - /* Not used, so don't bother boxing. In fact, the original value - might be cleared already, so we wan't legally box anymore. */ - drop = 1; - else - drop = 0; - - e = scheme_sfs_expr(SCHEME_PTR2_VAL(data), info, -1); - - if (drop) - return e; - else { - SCHEME_PTR2_VAL(data) = e; - return data; - } -} - -Scheme_Object *scheme_bangboxenv_jit(Scheme_Object *data) -{ - Scheme_Object *orig, *naya, *new_data; - - orig = SCHEME_PTR2_VAL(data); - naya = scheme_jit_expr(orig); - if (SAME_OBJ(naya, orig)) - return data; - else { - new_data = scheme_alloc_object(); - new_data->type = scheme_boxenv_type; - SCHEME_PTR1_VAL(new_data) = SCHEME_PTR1_VAL(data); - SCHEME_PTR2_VAL(new_data) = naya; - return new_data; - } -} - -void scheme_bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - scheme_validate_boxenv(SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)), port, stack, depth, delta, letlimit); - - scheme_validate_expr(port, SCHEME_PTR2_VAL(data), stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, result_ignored, vc, tailpos, 0, procs); -} - -/**********************************************************************/ -/* let, let-values, letrec, etc. */ -/**********************************************************************/ - -static int is_liftable_prim(Scheme_Object *v) -{ - if (SCHEME_PRIMP(v)) { - if ((((Scheme_Primitive_Proc *)v)->pp.flags & SCHEME_PRIM_OPT_MASK) - >= SCHEME_PRIM_OPT_IMMEDIATE) - return 1; - } - - return 0; -} - -static int is_liftable(Scheme_Object *o, int bind_count, int fuel, int as_rator) -{ - Scheme_Type t = SCHEME_TYPE(o); - - switch (t) { - case scheme_compiled_unclosed_procedure_type: - return !as_rator; - case scheme_case_lambda_sequence_type: - return !as_rator; - case scheme_compiled_toplevel_type: - return 1; - case scheme_local_type: - if (SCHEME_LOCAL_POS(o) > bind_count) - return 1; - break; - case scheme_branch_type: - if (fuel) { - Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)o; - if (is_liftable(b->test, bind_count, fuel - 1, 0) - && is_liftable(b->tbranch, bind_count, fuel - 1, as_rator) - && is_liftable(b->fbranch, bind_count, fuel - 1, as_rator)) - return 1; - } - break; - case scheme_application_type: - { - Scheme_App_Rec *app = (Scheme_App_Rec *)o; - int i; - if (!is_liftable_prim(app->args[0])) - return 0; - if (0) /* not resolved, yet */ - if (bind_count >= 0) - bind_count += app->num_args; - for (i = app->num_args + 1; i--; ) { - if (!is_liftable(app->args[i], bind_count, fuel - 1, 1)) - return 0; - } - return 1; - } - break; - case scheme_application2_type: - { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)o; - if (!is_liftable_prim(app->rator)) - return 0; - if (0) /* not resolved, yet */ - if (bind_count >= 0) - bind_count += 1; - if (is_liftable(app->rator, bind_count, fuel - 1, 1) - && is_liftable(app->rand, bind_count, fuel - 1, 1)) - return 1; - } - break; - case scheme_application3_type: - { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)o; - if (!is_liftable_prim(app->rator)) - return 0; - if (0) /* not resolved, yet */ - if (bind_count >= 0) - bind_count += 2; - if (is_liftable(app->rator, bind_count, fuel - 1, 1) - && is_liftable(app->rand1, bind_count, fuel - 1, 1) - && is_liftable(app->rand2, bind_count, fuel - 1, 1)) - return 1; - } - break; - case scheme_compiled_let_void_type: - { - Scheme_Let_Header *lh = (Scheme_Let_Header *)o; - int i; - int post_bind = !(SCHEME_LET_FLAGS(lh) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); - - if (post_bind) { - o = lh->body; - for (i = lh->num_clauses; i--; ) { - if (!is_liftable(((Scheme_Compiled_Let_Value *)o)->value, bind_count, fuel - 1, as_rator)) - return 0; - o = ((Scheme_Compiled_Let_Value *)o)->body; - } - if (is_liftable(o, bind_count + lh->count, fuel - 1, as_rator)) - return 1; - } - break; - } - default: - if (t > _scheme_compiled_values_types_) - return 1; - } - - return 0; -} - -int scheme_compiled_propagate_ok(Scheme_Object *value, Optimize_Info *info) -{ - if (scheme_compiled_duplicate_ok(value)) - return 1; - - if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) { - int sz; - sz = scheme_closure_body_size((Scheme_Closure_Data *)value, 1, info, NULL); - if ((sz >= 0) && (sz <= MAX_PROC_INLINE_SIZE)) - return 1; - } - - if (SAME_TYPE(scheme_case_lambda_sequence_type, SCHEME_TYPE(value))) { - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)value; - int i; - for (i = cl->count; i--; ) { - if (!scheme_compiled_propagate_ok(cl->array[i], info)) - return 0; - } - return 1; - } - - - if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_toplevel_type)) { - if (info->top_level_consts) { - int pos; - pos = SCHEME_TOPLEVEL_POS(value); - value = scheme_hash_get(info->top_level_consts, scheme_make_integer(pos)); - value = scheme_no_potential_size(value); - if (value) - return 1; - } - } - - return 0; -} - -int scheme_is_statically_proc(Scheme_Object *value, Optimize_Info *info) -{ - while (1) { - if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_unclosed_procedure_type)) - return 1; - else if (SAME_TYPE(SCHEME_TYPE(value), scheme_case_lambda_sequence_type)) { - return 1; - } else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_let_void_type)) { - /* Look for (let ([x ]) ), which is generated for optional arguments. */ - Scheme_Let_Header *lh = (Scheme_Let_Header *)value; - if (lh->num_clauses == 1) { - Scheme_Compiled_Let_Value *lv = (Scheme_Compiled_Let_Value *)lh->body; - if (scheme_omittable_expr(lv->value, lv->count, 20, 0, NULL, -1)) { - value = lv->body; - info = NULL; - } else - break; - } else - break; - } else - break; - } - - return 0; -} - -Scheme_Object *scheme_make_noninline_proc(Scheme_Object *e) -{ - Scheme_Object *ni; - - ni = scheme_alloc_small_object(); - ni->type = scheme_noninline_proc_type; - SCHEME_PTR_VAL(ni) = e; - - return ni; -} - -static int is_values_apply(Scheme_Object *e) -{ - if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { - Scheme_App_Rec *app = (Scheme_App_Rec *)e; - return SAME_OBJ(scheme_values_func, app->args[0]); - } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; - return SAME_OBJ(scheme_values_func, app->rator); - } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; - return SAME_OBJ(scheme_values_func, app->rator); - } - - return 0; -} - -static void unpack_values_application(Scheme_Object *e, Scheme_Compiled_Let_Value *naya, - int rev_bind_order) -{ - if (SAME_TYPE(SCHEME_TYPE(e), scheme_application_type)) { - Scheme_App_Rec *app = (Scheme_App_Rec *)e; - int i; - for (i = 0; i < app->num_args; i++) { - if (rev_bind_order) - naya->value = app->args[app->num_args - i]; - else - naya->value = app->args[i + 1]; - naya = (Scheme_Compiled_Let_Value *)naya->body; - } - } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application2_type)) { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)e; - naya->value = app->rand; - } else if (SAME_TYPE(SCHEME_TYPE(e), scheme_application3_type)) { - Scheme_App3_Rec *app = (Scheme_App3_Rec *)e; - naya->value = (rev_bind_order ? app->rand2 : app->rand1); - naya = (Scheme_Compiled_Let_Value *)naya->body; - naya->value = (rev_bind_order ? app->rand1 : app->rand2); - } -} - -static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start, - Scheme_Compiled_Let_Value *pre_body, - Optimize_Info *body_info) -{ - Scheme_Compiled_Let_Value *clv; - Scheme_Object *value, *clone, *pr; - Scheme_Object *last = NULL, *first = NULL; - - clv = retry_start; - while (1) { - value = clv->value; - if (IS_COMPILED_PROC(value)) { - clone = scheme_optimize_clone(1, value, body_info, 0, 0); - if (clone) { - pr = scheme_make_raw_pair(scheme_make_raw_pair(value, clone), NULL); - } else - pr = scheme_make_raw_pair(NULL, NULL); - if (last) - SCHEME_CDR(last) = pr; - else - first = pr; - last = pr; - } - if (clv == pre_body) - break; - clv = (Scheme_Compiled_Let_Value *)clv->body; - } - - return first; -} - -static int set_code_flags(Scheme_Compiled_Let_Value *retry_start, - Scheme_Compiled_Let_Value *pre_body, - Scheme_Object *clones, - int set_flags, int mask_flags, int just_tentative, - int merge_flonum) -{ - Scheme_Case_Lambda *cl, *cl2, *cl3; - Scheme_Compiled_Let_Value *clv; - Scheme_Object *value, *first; - int flags = CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS; - Scheme_Closure_Data *data, *data2, *data3; - int i, count; - - /* The first in a clone pair is the one that is consulted for - references. The second one is the clone, and it's the one whose - flags are updated by optimization. So consult the clone, and set - flags in both. */ - - clv = retry_start; - while (clones) { - value = clv->value; - if (IS_COMPILED_PROC(value)) { - first = SCHEME_CAR(clones); - - if (first) { - if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) { - count = 1; - cl = NULL; - cl2 = NULL; - cl3 = NULL; - } else { - cl = (Scheme_Case_Lambda *)value; - cl2 = (Scheme_Case_Lambda *)SCHEME_CAR(first); - cl3 = (Scheme_Case_Lambda *)SCHEME_CDR(first); - count = cl->count; - } - - for (i = 0; i < count; i++) { - if (cl) { - data = (Scheme_Closure_Data *)cl->array[i]; - data2 = (Scheme_Closure_Data *)cl2->array[i]; - data3 = (Scheme_Closure_Data *)cl3->array[i]; - } else { - data = (Scheme_Closure_Data *)value; - data2 = (Scheme_Closure_Data *)SCHEME_CAR(first); - data3 = (Scheme_Closure_Data *)SCHEME_CDR(first); - } - - if (merge_flonum) { - scheme_merge_closure_flonum_map(data, data2); - scheme_merge_closure_flonum_map(data, data3); - scheme_merge_closure_flonum_map(data, data2); - } - - if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { - flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data)); - SCHEME_CLOSURE_DATA_FLAGS(data2) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data2) & mask_flags); - SCHEME_CLOSURE_DATA_FLAGS(data3) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data3) & mask_flags); - } - } - } - - clones = SCHEME_CDR(clones); - } - - if (clv == pre_body) - break; - clv = (Scheme_Compiled_Let_Value *)clv->body; - } - - return flags; -} - -int scheme_compiled_proc_body_size(Scheme_Object *o) -{ - if (SAME_TYPE(SCHEME_TYPE(o), scheme_compiled_unclosed_procedure_type)) - return scheme_closure_body_size((Scheme_Closure_Data *)o, 0, NULL, NULL); - else if (SAME_TYPE(SCHEME_TYPE(o), scheme_case_lambda_sequence_type)) { - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)o; - int i, sz = 0; - for (i = cl->count; i--; ) { - sz += scheme_closure_body_size((Scheme_Closure_Data *)cl->array[i], 0, NULL, NULL); - } - return sz; - } else - return 0; -} - -static int expr_size(Scheme_Object *o, Optimize_Info *info) -{ - return scheme_compiled_proc_body_size(o) + 1; -} - -static int might_invoke_call_cc(Scheme_Object *value) -{ - return !is_liftable(value, -1, 10, 0); -} - -static int worth_lifting(Scheme_Object *v) -{ - Scheme_Type lhs; - lhs = SCHEME_TYPE(v); - if ((lhs == scheme_compiled_unclosed_procedure_type) - || (lhs == scheme_case_lambda_sequence_type) - || (lhs == scheme_local_type) - || (lhs == scheme_compiled_toplevel_type) - || (lhs == scheme_compiled_quote_syntax_type) - || (lhs > _scheme_compiled_values_types_)) - return 1; - return 0; -} - -Scheme_Object * -scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, int context) -{ - Optimize_Info *sub_info, *body_info, *rhs_info; - Scheme_Let_Header *head = (Scheme_Let_Header *)form; - Scheme_Compiled_Let_Value *clv, *pre_body, *retry_start, *prev_body; - Scheme_Object *body, *value, *ready_pairs = NULL, *rp_last = NULL, *ready_pairs_start; - Scheme_Once_Used *first_once_used = NULL, *last_once_used = NULL, *once_used; - int i, j, pos, is_rec, not_simply_let_star = 0, undiscourage, split_shift, skip_opts = 0; - int size_before_opt, did_set_value, checked_once; - int remove_last_one = 0, inline_fuel, rev_bind_order; - int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); - -# define pos_EARLIER(a, b) (rev_bind_order ? ((a) > (b)) : ((a) < (b))) - - if (context & OPT_CONTEXT_BOOLEAN) { - /* Special case: (let ([x M]) (if x x N)), where x is not in N, - to (if M #t N), since we're in a test position. */ - if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) { - clv = (Scheme_Compiled_Let_Value *)head->body; - if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type) - && (((clv->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT) - == 2)) { - Scheme_Branch_Rec *b = (Scheme_Branch_Rec *)clv->body; - if (SAME_TYPE(SCHEME_TYPE(b->test), scheme_local_type) - && SAME_TYPE(SCHEME_TYPE(b->tbranch), scheme_local_type) - && !SCHEME_LOCAL_POS(b->test) - && !SCHEME_LOCAL_POS(b->tbranch)) { - Scheme_Branch_Rec *b3; - - b3 = MALLOC_ONE_TAGGED(Scheme_Branch_Rec); - b3->so.type = scheme_branch_type; - b3->test = clv->value; - b3->tbranch = scheme_true; - if (post_bind) { - /* still need a `let' around N: */ - b3->fbranch = (Scheme_Object *)head; - clv->value = scheme_false; - clv->flags[0] = 0; /* variable now unused */ - clv->body = b->fbranch; - } else { - b3->fbranch = b->fbranch; - } - - if (post_bind) - sub_info = info; - else - sub_info = scheme_optimize_info_add_frame(info, 1, 0, 0); - - form = scheme_optimize_expr((Scheme_Object *)b3, sub_info, context); - - if (!post_bind) { - info->single_result = sub_info->single_result; - info->preserves_marks = sub_info->preserves_marks; - scheme_optimize_info_done(sub_info); - } - - return form; - } - } - } - } - - /* Special case: (let ([x E]) x) where E is lambda, case-lambda, or - a constant. (If we allowed arbitrary E here, it would affect the - tailness of E.) */ - if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) { - clv = (Scheme_Compiled_Let_Value *)head->body; - if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type) - && (((Scheme_Local *)clv->body)->position == 0)) { - if (worth_lifting(clv->value)) { - if (post_bind) { - /* Just drop the let */ - return scheme_optimize_expr(clv->value, info, context); - } else { - info = scheme_optimize_info_add_frame(info, 1, 0, 0); - body = scheme_optimize_expr(clv->value, info, context); - info->next->single_result = info->single_result; - info->next->preserves_marks = info->preserves_marks; - scheme_optimize_info_done(info); - return body; - } - } - } - } - - is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE); - - if (!is_rec) { - int try_again; - do { - try_again = 0; - /* (let ([x (let~ ([y M]) N)]) P) => (let~ ([y M]) (let ([x N]) P)) - or (let ([x (begin M ... N)]) P) => (begin M ... (let ([x N]) P)) */ - if (post_bind) { - if (head->num_clauses == 1) { - clv = (Scheme_Compiled_Let_Value *)head->body; /* ([x ...]) */ - if (SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_let_void_type)) { - Scheme_Let_Header *lh = (Scheme_Let_Header *)clv->value; /* (let~ ([y ...]) ...) */ - - value = clv->body; /* = P */ - if (lh->count) - value = scheme_optimize_shift(value, lh->count, head->count); - if (value) { - clv->body = value; - - if (!lh->num_clauses) { - clv->value = lh->body; - lh->body = (Scheme_Object *)head; - } else { - body = lh->body; - for (i = lh->num_clauses - 1; i--; ) { - body = ((Scheme_Compiled_Let_Value *)body)->body; - } - clv->value = ((Scheme_Compiled_Let_Value *)body)->body; /* N */ - ((Scheme_Compiled_Let_Value *)body)->body = (Scheme_Object *)head; - } - - head = lh; - form = (Scheme_Object *)head; - is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE); - post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); - try_again = 1; - } - } else if (SAME_TYPE(SCHEME_TYPE(clv->value), scheme_sequence_type)) { - Scheme_Sequence *seq = (Scheme_Sequence *)clv->value; /* (begin M ... N) */ - - clv->value = seq->array[seq->count - 1]; - seq->array[seq->count - 1] = (Scheme_Object *)head; - - return scheme_optimize_expr((Scheme_Object *)seq, info, context); - } - } - } - } while (try_again); - } - - split_shift = 0; - if (is_rec) { - /* Check whether we should break a prefix out into its own - letrec set. */ - body = head->body; - j = 0; - for (i = 0; i < head->num_clauses - 1; i++) { - pre_body = (Scheme_Compiled_Let_Value *)body; - if (SCHEME_CLV_FLAGS(pre_body) & SCHEME_CLV_NO_GROUP_LATER_USES) { - /* yes --- break group here */ - Scheme_Let_Header *h2; - - j += pre_body->count; - i++; - - h2 = MALLOC_ONE_TAGGED(Scheme_Let_Header); - h2->iso.so.type = scheme_compiled_let_void_type; - h2->count = head->count - j; - h2->num_clauses = head->num_clauses - i; - h2->body = pre_body->body; - SCHEME_LET_FLAGS(h2) = SCHEME_LET_RECURSIVE; - - head->count = j; - head->num_clauses = i; - - pre_body->body = (Scheme_Object *)h2; - - split_shift = h2->count; - - body = head->body; - for (j = 0; j < i; j++) { - pre_body = (Scheme_Compiled_Let_Value *)body; - pre_body->position -= split_shift; - body = pre_body->body; - } - - break; - } else { - j += pre_body->count; - body = pre_body->body; - } - } - } - - body_info = scheme_optimize_info_add_frame(info, head->count, head->count, - post_bind ? SCHEME_POST_BIND_FRAME : 0); - if (post_bind) - rhs_info = scheme_optimize_info_add_frame(info, 0, 0, 0); - else if (split_shift) - rhs_info = scheme_optimize_info_add_frame(body_info, split_shift, 0, 0); - else - rhs_info = body_info; - - body = head->body; - for (i = head->num_clauses; i--; ) { - pre_body = (Scheme_Compiled_Let_Value *)body; - pos = pre_body->position; - for (j = pre_body->count; j--; ) { - if (pre_body->flags[j] & SCHEME_WAS_SET_BANGED) { - scheme_optimize_mutated(body_info, pos + j); - } else if (is_rec) { - /* Indicate that it's not yet ready, so it cannot be inlined: */ - Scheme_Object *rp; - rp = scheme_make_raw_pair(scheme_false, NULL); - if (rp_last) - SCHEME_CDR(rp_last) = rp; - else - ready_pairs = rp; - rp_last = rp; - scheme_optimize_propagate(body_info, pos+j, rp_last, 0); - } - } - body = pre_body->body; - } - - if (OPT_ESTIMATE_FUTURE_SIZES) { - if (is_rec && !body_info->letrec_not_twice) { - /* For each identifier bound to a procedure, register an initial - size estimate, which is used to discourage early loop unrolling - at the expense of later inlining. */ - body = head->body; - pre_body = NULL; - for (i = head->num_clauses; i--; ) { - pre_body = (Scheme_Compiled_Let_Value *)body; - pos = pre_body->position; - - if ((pre_body->count == 1) - && IS_COMPILED_PROC(pre_body->value) - && !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) { - scheme_optimize_propagate(body_info, pos, scheme_estimate_closure_size(pre_body->value), 0); - } - - body = pre_body->body; - } - rhs_info->use_psize = 1; - } - } - - rev_bind_order = 0; - if (is_rec) - rev_bind_order = 1; - else if (head->num_clauses > 1) { - int pos; - body = head->body; - pre_body = (Scheme_Compiled_Let_Value *)body; - pos = pre_body->position; - body = pre_body->body; - for (i = head->num_clauses - 1; i--; ) { - pre_body = (Scheme_Compiled_Let_Value *)body; - if (pre_body->position < pos) { - rev_bind_order = 1; - break; - } else if (pre_body->position > pos) { - break; - } - body = pre_body->body; - } - } - - prev_body = NULL; - body = head->body; - pre_body = NULL; - retry_start = NULL; - ready_pairs_start = NULL; - did_set_value = 0; - for (i = head->num_clauses; i--; ) { - pre_body = (Scheme_Compiled_Let_Value *)body; - pos = pre_body->position; - - size_before_opt = body_info->size; - - if ((pre_body->count == 1) - && IS_COMPILED_PROC(pre_body->value) - && !scheme_optimize_is_used(body_info, pos)) { - if (!body_info->transitive_use) { - mzshort **tu; - int *tu_len; - tu = (mzshort **)scheme_malloc(sizeof(mzshort *) * head->count); - tu_len = (int *)scheme_malloc_atomic(sizeof(int) * head->count); - memset(tu_len, 0, sizeof(int) * head->count); - body_info->transitive_use = tu; - body_info->transitive_use_len = tu_len; - } - body_info->transitive_use_pos = pos + 1; - } - - if (is_rec && OPT_DISCOURAGE_EARLY_INLINE && !rhs_info->letrec_not_twice - && IS_COMPILED_PROC(pre_body->value)) { - inline_fuel = rhs_info->inline_fuel; - if (inline_fuel > 2) - rhs_info->inline_fuel = 2; - rhs_info->letrec_not_twice++; - undiscourage = 1; - } else { - inline_fuel = 0; - undiscourage = 0; - } - - if (!skip_opts) { - value = scheme_optimize_expr(pre_body->value, rhs_info, 0); - pre_body->value = value; - } else { - value = pre_body->value; - --skip_opts; - } - - if (undiscourage) { - rhs_info->inline_fuel = inline_fuel; - --rhs_info->letrec_not_twice; - } - - body_info->transitive_use_pos = 0; - - if (is_rec && !not_simply_let_star) { - /* Keep track of whether we can simplify to let*: */ - if (might_invoke_call_cc(value) - || scheme_optimize_any_uses(body_info, 0, pos+pre_body->count)) - not_simply_let_star = 1; - } - - /* Change (let-values ([(id ...) (values e ...)]) body) - to (let-values ([id e] ...) body) for simple e. */ - if ((pre_body->count != 1) - && is_values_apply(value) - && scheme_omittable_expr(value, pre_body->count, -1, 0, info, - (is_rec - ? (pre_body->position + pre_body->count) - : -1))) { - if (!pre_body->count && !i) { - /* We want to drop the clause entirely, but doing it - here messes up the loop for letrec. So wait and - remove it at the end. */ - remove_last_one = 1; - } else { - Scheme_Compiled_Let_Value *naya; - Scheme_Object *rest = pre_body->body; - int *new_flags; - int cnt; - - /* This conversion may reorder the expressions. */ - if (pre_body->count) { - if (rev_bind_order) - cnt = 0; - else - cnt = pre_body->count - 1; - - while (1) { - naya = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - naya->iso.so.type = scheme_compiled_let_value_type; - naya->body = rest; - naya->count = 1; - naya->position = pre_body->position + cnt; - new_flags = (int *)scheme_malloc_atomic(sizeof(int)); - new_flags[0] = pre_body->flags[cnt]; - naya->flags = new_flags; - rest = (Scheme_Object *)naya; - - if (rev_bind_order) { - cnt++; - if (cnt >= pre_body->count) - break; - } else { - if (!cnt) - break; - cnt--; - } - } - } - - naya = (Scheme_Compiled_Let_Value *)rest; - unpack_values_application(value, naya, rev_bind_order); - if (prev_body) - prev_body->body = (Scheme_Object *)naya; - else - head->body = (Scheme_Object *)naya; - head->num_clauses += (pre_body->count - 1); - i += (pre_body->count - 1); - if (pre_body->count) { - /* We're backing up. Since the RHSs have been optimized - already, don re-optimize. */ - skip_opts = pre_body->count - 1; - pre_body = naya; - body = (Scheme_Object *)naya; - value = pre_body->value; - pos = pre_body->position; - } else { - /* We've dropped this clause entirely. */ - i++; - if (i > 0) { - body = (Scheme_Object *)naya; - continue; - } else - break; - } - } - } - - checked_once = 0; - - if ((pre_body->count == 1) - && !(pre_body->flags[0] & SCHEME_WAS_SET_BANGED)) { - int indirect = 0, indirect_binding = 0; - - while (indirect < 10) { - if (SAME_TYPE(SCHEME_TYPE(value), scheme_sequence_type)) { - Scheme_Sequence *seq = (Scheme_Sequence *)value; - value = seq->array[seq->count - 1]; - indirect++; - } else if (SAME_TYPE(SCHEME_TYPE(value), scheme_compiled_let_void_type)) { - Scheme_Let_Header *head2 = (Scheme_Let_Header *)value; - int i; - - if (head2->num_clauses < 10) { - value = head2->body; - for (i = head2->num_clauses; i--; ) { - value = ((Scheme_Compiled_Let_Value *)value)->body; - } - } - indirect++; - if (head2->count) - indirect_binding = 1; - } else - break; - } - - if (indirect_binding) { - /* only allow constants */ - if (SCHEME_TYPE(value) < _scheme_compiled_values_types_) - value = NULL; - } - - if (value && SAME_TYPE(SCHEME_TYPE(value), scheme_local_type)) { - /* Don't optimize reference to a local binding - that's not available yet, or that's mutable. */ - int vpos; - vpos = SCHEME_LOCAL_POS(value); - if (!post_bind && (vpos < head->count) && !pos_EARLIER(vpos, pos)) - value = NULL; - else { - /* Convert value back to a pre-optimized local coordinates. - Unless post_bind, this must be done with respect to - body_info, not rhs_info, because we attach the value to - body_info: */ - value = scheme_optimize_reverse(post_bind ? rhs_info : body_info, vpos, 1); - - /* Double-check that the value is ready, because we might be - nested in the RHS of a `letrec': */ - if (value) - if (!scheme_optimize_info_is_ready(body_info, SCHEME_LOCAL_POS(value))) - value = NULL; - } - } - - if (value && (scheme_compiled_propagate_ok(value, body_info))) { - int cnt; - - if (is_rec) - cnt = 2; - else - cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); - - scheme_optimize_propagate(body_info, pos, value, cnt == 1); - did_set_value = 1; - checked_once = 1; - } else if (value && !is_rec) { - int cnt; - - if (scheme_expr_produces_flonum(value)) - scheme_optimize_produces_flonum(body_info, pos); - - if (!indirect) { - checked_once = 1; - cnt = ((pre_body->flags[0] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); - if (cnt == 1) { - /* used only once; we may be able to shift the expression to the use - site, instead of binding to a temporary */ - once_used = scheme_make_once_used(value, pos, rhs_info->vclock, NULL); - if (!last_once_used) - first_once_used = once_used; - else - last_once_used->next = once_used; - last_once_used = once_used; - scheme_optimize_propagate(body_info, pos, (Scheme_Object *)once_used, 1); - } - } - } - } - - if (!checked_once) { - /* Didn't handle once-used check in case of copy propagation, so check here. */ - int i, cnt; - for (i = pre_body->count; i--; ) { - if (!(pre_body->flags[i] & SCHEME_WAS_SET_BANGED)) { - cnt = ((pre_body->flags[i] & SCHEME_USE_COUNT_MASK) >> SCHEME_USE_COUNT_SHIFT); - if (cnt == 1) { - /* Need to register as once-used, in case of copy propagation */ - once_used = scheme_make_once_used(NULL, pos+i, rhs_info->vclock, NULL); - if (!last_once_used) - first_once_used = once_used; - else - last_once_used->next = once_used; - last_once_used = once_used; - scheme_optimize_propagate(body_info, pos+i, (Scheme_Object *)once_used, 1); - } - } - } - } - - if (!retry_start) { - retry_start = pre_body; - ready_pairs_start = ready_pairs; - } - - /* Re-optimize to inline letrec bindings? */ - if (is_rec - && !body_info->letrec_not_twice - && ((i < 1) - || (!scheme_is_compiled_procedure(((Scheme_Compiled_Let_Value *)pre_body->body)->value, 1, 1) - && !is_liftable(((Scheme_Compiled_Let_Value *)pre_body->body)->value, head->count, 5, 1)))) { - if (did_set_value) { - /* Next RHS ends a reorderable sequence. - Re-optimize from retry_start to pre_body, inclusive. - For procedures, assume CLOS_SINGLE_RESULT and CLOS_PRESERVES_MARKS for all, - but then assume not for all if any turn out not (i.e., approximate fix point). */ - int flags; - Scheme_Object *clones, *cl, *cl_first; - /* Reset "ready" flags: */ - for (rp_last = ready_pairs_start; !SAME_OBJ(rp_last, ready_pairs); rp_last = SCHEME_CDR(rp_last)) { - SCHEME_CAR(rp_last) = scheme_false; - } - /* Set-flags loop: */ - clones = make_clones(retry_start, pre_body, rhs_info); - (void)set_code_flags(retry_start, pre_body, clones, - CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, - 0xFFFF, - 0, - 0); - /* Re-optimize loop: */ - clv = retry_start; - cl = clones; - while (1) { - value = clv->value; - if (cl) { - cl_first = SCHEME_CAR(cl); - if (!cl_first) - cl = SCHEME_CDR(cl); - } else - cl_first = NULL; - if (cl_first && SAME_OBJ(value, SCHEME_CAR(cl_first))) { - /* Try optimization. */ - Scheme_Object *self_value; - int sz; - char use_psize; - - if ((clv->count == 1) - && rhs_info->transitive_use - && !scheme_optimize_is_used(body_info, clv->position)) { - body_info->transitive_use[clv->position] = NULL; - body_info->transitive_use_pos = clv->position + 1; - } - - cl = SCHEME_CDR(cl); - self_value = SCHEME_CDR(cl_first); - - /* Drop old size, and remove old inline fuel: */ - sz = scheme_compiled_proc_body_size(value); - rhs_info->size -= (sz + 1); - - /* Setting letrec_not_twice prevents inlinining - of letrec bindings in this RHS. There's a small - chance that we miss some optimizations, but we - avoid the possibility of N^2 behavior. */ - if (!OPT_DISCOURAGE_EARLY_INLINE) - rhs_info->letrec_not_twice++; - use_psize = rhs_info->use_psize; - rhs_info->use_psize = info->use_psize; - - value = scheme_optimize_expr(self_value, rhs_info, 0); - - if (!OPT_DISCOURAGE_EARLY_INLINE) - --rhs_info->letrec_not_twice; - rhs_info->use_psize = use_psize; - - clv->value = value; - - if (!(clv->flags[0] & SCHEME_WAS_SET_BANGED)) { - if (scheme_compiled_propagate_ok(value, rhs_info)) { - /* Register re-optimized as the value for the binding, but - maybe only if it didn't grow too much: */ - int new_sz; - if (OPT_LIMIT_FUNCTION_RESIZE) - new_sz = scheme_compiled_proc_body_size(value); - else - new_sz = 0; - if (new_sz < 4 * sz) - scheme_optimize_propagate(body_info, clv->position, value, 0); - } - } - - body_info->transitive_use_pos = 0; - } - if (clv == pre_body) - break; - { - /* Since letrec is really letrec*, the variables - for this binding are now ready: */ - int i; - for (i = clv->count; i--; ) { - if (!(clv->flags[i] & SCHEME_WAS_SET_BANGED)) { - SCHEME_CAR(ready_pairs_start) = scheme_true; - ready_pairs_start = SCHEME_CDR(ready_pairs_start); - } - } - } - clv = (Scheme_Compiled_Let_Value *)clv->body; - } - /* Check flags loop: */ - flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0, 0); - /* Reset-flags loop: */ - (void)set_code_flags(retry_start, pre_body, clones, - (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), - ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE), - 1, - 1); - } - retry_start = NULL; - ready_pairs_start = NULL; - did_set_value = 0; - } - - if (is_rec) { - /* Since letrec is really letrec*, the variables - for this binding are now ready: */ - int i; - for (i = pre_body->count; i--; ) { - if (!(pre_body->flags[i] & SCHEME_WAS_SET_BANGED)) { - SCHEME_CAR(ready_pairs) = scheme_true; - ready_pairs = SCHEME_CDR(ready_pairs); - } - } - } - - if (remove_last_one) { - head->num_clauses -= 1; - body = (Scheme_Object *)pre_body->body; - if (prev_body) { - prev_body->body = body; - pre_body = prev_body; - } else { - head->body = body; - pre_body = NULL; - } - break; - } - - prev_body = pre_body; - body = pre_body->body; - } - - if (post_bind) { - body_info->size = rhs_info->size; - body_info->vclock = rhs_info->vclock; - } - - if (split_shift) { - scheme_optimize_info_done(rhs_info); - } - - body = scheme_optimize_expr(body, body_info, scheme_optimize_tail_context(context)); - if (head->num_clauses) - pre_body->body = body; - else - head->body = body; - - info->single_result = body_info->single_result; - info->preserves_marks = body_info->preserves_marks; - info->vclock = body_info->vclock; - - /* Clear used flags where possible */ - body = head->body; - for (i = head->num_clauses; i--; ) { - int used = 0, j; - - pre_body = (Scheme_Compiled_Let_Value *)body; - pos = pre_body->position; - - for (j = pre_body->count; j--; ) { - if (scheme_optimize_is_used(body_info, pos+j)) { - used = 1; - break; - } - } - - if (!used - && (scheme_omittable_expr(pre_body->value, pre_body->count, -1, 0, info, -1) - || ((pre_body->count == 1) - && first_once_used - && (first_once_used->pos == pos) - && first_once_used->used))) { - for (j = pre_body->count; j--; ) { - if (pre_body->flags[j] & SCHEME_WAS_USED) { - pre_body->flags[j] -= SCHEME_WAS_USED; - } - - if (first_once_used && (first_once_used->pos == (pos + j))) - first_once_used = first_once_used->next; - } - if (pre_body->count == 1) { - /* Drop expr and deduct from size to aid further inlining. */ - int sz; - sz = expr_size(pre_body->value, info); - pre_body->value = scheme_false; - info->size -= sz; - } - } else { - for (j = pre_body->count; j--; ) { - pre_body->flags[j] |= SCHEME_WAS_USED; - if (scheme_optimize_is_flonum_arg(body_info, pos+j, 0)) - pre_body->flags[j] |= SCHEME_WAS_FLONUM_ARGUMENT; - - if (first_once_used && (first_once_used->pos == (pos+j))) { - if (first_once_used->vclock < 0) { - /* single-use no longer true, due to copy propagation */ - pre_body->flags[j] |= SCHEME_USE_COUNT_MASK; - } - first_once_used = first_once_used->next; - } - } - info->size += 1; - } - body = pre_body->body; - } - - /* Optimized away all clauses? */ - if (!head->num_clauses) { - scheme_optimize_info_done(body_info); - return head->body; - } - - if (is_rec && !not_simply_let_star) { - /* We can simplify letrec to let* */ - SCHEME_LET_FLAGS(head) -= SCHEME_LET_RECURSIVE; - SCHEME_LET_FLAGS(head) |= SCHEME_LET_STAR; - } - - { - int extract_depth = 0; - - value = NULL; - - /* Check again for (let ([x ]) x). */ - if (!is_rec && (head->count == 1) && (head->num_clauses == 1)) { - clv = (Scheme_Compiled_Let_Value *)head->body; - if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type) - && (((Scheme_Local *)clv->body)->position == 0)) { - if (worth_lifting(clv->value)) { - value = clv->value; - extract_depth = 1; - } - } - } - - /* Check for (let ([unused #f] ...) ) */ - if (!value) { - if (head->count == head->num_clauses) { - body = head->body; - for (i = head->num_clauses; i--; ) { - pre_body = (Scheme_Compiled_Let_Value *)body; - if ((pre_body->count != 1) - || !SCHEME_FALSEP(pre_body->value) - || (pre_body->flags[0] & SCHEME_WAS_USED)) - break; - body = pre_body->body; - } - if (i < 0) { - if (worth_lifting(body)) { - value = body; - extract_depth = head->count; - rhs_info = body_info; - post_bind = 0; - } - } - } - } - - if (value) { - value = scheme_optimize_clone(1, value, rhs_info, 0, 0); - - if (value) { - sub_info = scheme_optimize_info_add_frame(info, post_bind ? 0 : extract_depth, 0, 0); - sub_info->inline_fuel = 0; - value = scheme_optimize_expr(value, sub_info, context); - info->single_result = sub_info->single_result; - info->preserves_marks = sub_info->preserves_marks; - scheme_optimize_info_done(sub_info); - return value; - } - } - } - - scheme_optimize_info_done(body_info); - - return form; -} - -static int is_lifted_reference(Scheme_Object *v) -{ - if (SCHEME_RPAIRP(v)) - return 1; - - return (SAME_TYPE(SCHEME_TYPE(v), scheme_toplevel_type) - && (SCHEME_TOPLEVEL_FLAGS(v) & SCHEME_TOPLEVEL_CONST)); -} - -static int is_closed_reference(Scheme_Object *v) -{ - /* Look for a converted function (possibly with no new arguments) - that is accessed directly as a closure, instead of through a - top-level reference. */ - if (SCHEME_RPAIRP(v)) { - v = SCHEME_CAR(v); - return SCHEME_PROCP(v); - } - - return 0; -} - -static Scheme_Object *scheme_resolve_generate_stub_closure() -{ - Scheme_Closure *cl; - Scheme_Object **ca; - - cl = scheme_malloc_empty_closure(); - - ca = MALLOC_N(Scheme_Object*, 4); - ca[0] = scheme_make_integer(0); - ca[1] = NULL; - ca[2] = scheme_make_integer(0); - ca[3] = NULL; - - return scheme_make_raw_pair((Scheme_Object *)cl, (Scheme_Object *)ca); -} - -static void shift_lift(Scheme_Object *lifted, int frame_size, int lifted_frame_size) -{ - int i, cnt, delta; - Scheme_Object **ca; - mzshort *map; - - if (!lifted) return; - if (!SCHEME_RPAIRP(lifted)) return; - - ca = (Scheme_Object **)SCHEME_CDR(lifted); - cnt = SCHEME_INT_VAL(ca[0]); - map = (mzshort *)ca[1]; - - delta = (frame_size - lifted_frame_size); - - for (i = 0; i < cnt; i++) { - map[i] += delta; - } -} - -static int get_convert_arg_count(Scheme_Object *lift) -{ - if (!lift) - return 0; - else if (SCHEME_RPAIRP(lift)) { - Scheme_Object **ca; - ca = (Scheme_Object **)SCHEME_CDR(lift); - return SCHEME_INT_VAL(ca[0]); - } else - return 0; -} - -static Scheme_Object *drop_zero_value_return(Scheme_Object *expr) -{ - if (SAME_TYPE(SCHEME_TYPE(expr), scheme_sequence_type)) { - if (((Scheme_Sequence *)expr)->count == 2) { - if (SAME_TYPE(SCHEME_TYPE(((Scheme_Sequence *)expr)->array[1]), scheme_application_type)) { - if (((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->num_args == 0) { - if (SAME_OBJ(scheme_values_func, ((Scheme_App_Rec *)((Scheme_Sequence *)expr)->array[1])->args[0])) { - return ((Scheme_Sequence *)expr)->array[0]; - } - } - } - } - } - - return NULL; -} - -Scheme_Object * -scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info) -{ - Resolve_Info *linfo, *val_linfo = NULL; - Scheme_Let_Header *head = (Scheme_Let_Header *)form; - Scheme_Compiled_Let_Value *clv, *pre_body; - Scheme_Let_Value *lv, *last = NULL; - Scheme_Object *first = NULL, *body, *last_body = NULL, *last_seq = NULL; - Scheme_Letrec *letrec; - mzshort *skips, skips_fast[5]; - char *flonums, flonums_fast[5]; - Scheme_Object **lifted, *lifted_fast[5], *boxes; - int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc; - int rec_proc_nonapply = 0; - int max_let_depth = 0; - int resolve_phase, num_skips; - Scheme_Object **lifted_recs; - int post_bind = !(SCHEME_LET_FLAGS(head) & (SCHEME_LET_RECURSIVE | SCHEME_LET_STAR)); - - /* Find body: */ - body = head->body; - pre_body = NULL; - for (i = head->num_clauses; i--; ) { - pre_body = (Scheme_Compiled_Let_Value *)body; - body = pre_body->body; - } - - recbox = 0; - if (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) { - /* Do we need to box vars in a letrec? */ - clv = (Scheme_Compiled_Let_Value *)head->body; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - int is_proc, is_lift; - - if ((clv->count == 1) - && !(clv->flags[0] & SCHEME_WAS_USED)) { - /* skip */ - } else { - if (clv->count == 1) - is_proc = scheme_is_compiled_procedure(clv->value, 1, 1); - else - is_proc = 0; - - if (is_proc) - is_lift = 0; - else if (SCHEME_CLV_FLAGS(clv) & SCHEME_CLV_NO_GROUP_USES) - is_lift = 1; - else - is_lift = is_liftable(clv->value, head->count, 5, 1); - - if (!is_proc && !is_lift) { - recbox = 1; - break; - } else { - if (!is_lift) { - /* is_proc must be true ... */ - int j; - - for (j = 0; j < clv->count; j++) { - if (clv->flags[j] & SCHEME_WAS_SET_BANGED) { - recbox = 1; - break; - } - } - if (recbox) - break; - - if (scheme_is_compiled_procedure(clv->value, 0, 0)) { - num_rec_procs++; - if (!(clv->flags[0] & SCHEME_WAS_ONLY_APPLIED)) - rec_proc_nonapply = 1; - } - } - } - } - } - - if (recbox) - num_rec_procs = 0; - } else { - /* Sequence of single-value, non-assigned lets? */ - int some_used = 0; - - clv = (Scheme_Compiled_Let_Value *)head->body; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - if (clv->count != 1) - break; - if (clv->flags[0] & SCHEME_WAS_SET_BANGED) - break; - if (clv->flags[0] & SCHEME_WAS_USED) - some_used = 1; - } - - if (i < 0) { - /* Yes - build chain of Scheme_Let_Ones and we're done: */ - int skip_count = 0, frame_size, lifts_frame_size = 0; - int j, k, n, rev_bind_order = 0; - - if (head->num_clauses > 1) { - clv = (Scheme_Compiled_Let_Value *)head->body; - if (clv->position > ((Scheme_Compiled_Let_Value *)clv->body)->position) - rev_bind_order = 1; - } - - j = head->num_clauses; - if (j <= 5) { - skips = skips_fast; - lifted = lifted_fast; - flonums = flonums_fast; - } else { - skips = MALLOC_N_ATOMIC(mzshort, j); - lifted = MALLOC_N(Scheme_Object*, j); - flonums = MALLOC_N_ATOMIC(char, j); - } - - clv = (Scheme_Compiled_Let_Value *)head->body; - for (i = 0; i < j; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) { - if (!(clv->flags[0] & SCHEME_WAS_USED)) - skips[i] = 1; - else - skips[i] = 0; - if ((clv->flags[0] & SCHEME_WAS_FLONUM_ARGUMENT) - && scheme_expr_produces_flonum(clv->value)) - flonums[i] = SCHEME_INFO_FLONUM_ARG; - else - flonums[i] = 0; - lifted[i] = NULL; - } - - clv = (Scheme_Compiled_Let_Value *)head->body; - for (i = 0; i < head->num_clauses; i++, clv = (Scheme_Compiled_Let_Value *)clv->body) { - Scheme_Object *le; - - if (!(clv->flags[0] & SCHEME_WAS_USED)) { - skip_count++; - } - - /* First `i+1' bindings now exist "at runtime", except those skipped. */ - /* The mapping is complicated because we now push in the order of - the variables, but it may have been compiled using the inverse order. */ - frame_size = i + 1 - skip_count; - if (lifts_frame_size != frame_size) { - /* We need to shift coordinates for any lifted[j] that is a - converted procedure. */ - for (j = i, k = 0; j >= 0; j--) { - shift_lift(lifted[j], frame_size, lifts_frame_size); - } - } - if (post_bind) { - linfo = scheme_resolve_info_extend(info, frame_size, 0, 0); - } else { - linfo = scheme_resolve_info_extend(info, frame_size, head->count, i + 1); - for (j = i, k = 0; j >= 0; j--) { - n = (rev_bind_order ? (head->count - j - 1) : j); - if (skips[j]) - scheme_resolve_info_add_mapping(linfo, n, -1, flonums[j], lifted[j]); - else - scheme_resolve_info_add_mapping(linfo, n, k++, flonums[j], lifted[j]); - } - } - lifts_frame_size = frame_size; - - if (skips[i]) { - le = scheme_void; - } else { - if ((clv->flags[0] & SCHEME_WAS_ONLY_APPLIED) - && SAME_TYPE(SCHEME_TYPE(clv->value), scheme_compiled_unclosed_procedure_type)) - le = scheme_resolve_closure_compilation(clv->value, linfo, 1, 1, 0, NULL); - else - le = scheme_resolve_expr(clv->value, linfo); - } - - if (max_let_depth < linfo->max_let_depth + frame_size) - max_let_depth = linfo->max_let_depth + frame_size; - scheme_merge_resolve_tl_map(info, linfo); - - if (is_lifted_reference(le)) { - lifted[i] = le; - - /* At this point, it's ok to change our mind - about skipping, because compilation for previous - RHSs did not look at this one. */ - if (!skips[i]) { - skips[i] = 1; - skip_count++; - } - } - - if (skips[i]) { - /* Unused binding, so drop it. */ - } else { - Scheme_Let_One *lo; - int et; - - lo = MALLOC_ONE_TAGGED(Scheme_Let_One); - lo->iso.so.type = scheme_let_one_type; - lo->value = le; - - et = scheme_get_eval_type(lo->value); - if (flonums[i]) - et |= LET_ONE_FLONUM; - SCHEME_LET_EVAL_TYPE(lo) = et; - - if (last) - ((Scheme_Let_One *)last)->body = (Scheme_Object *)lo; - else - first = (Scheme_Object *)lo; - last = (Scheme_Let_Value *)lo; - } - } - - frame_size = head->count - skip_count; - linfo = scheme_resolve_info_extend(info, frame_size, head->count, head->count); - - if (lifts_frame_size != frame_size) { - for (i = head->count; i--; ) { - /* We need to shift coordinates for any lifted[j] that is a - converted procedure. */ - shift_lift(lifted[i], frame_size, lifts_frame_size); - } - } - - for (k = 0, i = head->count; i--; ) { - n = (rev_bind_order ? (head->count - i - 1) : i); - if ((skips[i] != 0) && (skips[i] != 1)) scheme_signal_error("trashed\n"); - if (skips[i]) - scheme_resolve_info_add_mapping(linfo, n, -1, flonums[i], lifted[i]); - else - scheme_resolve_info_add_mapping(linfo, n, k++, flonums[i], lifted[i]); - } - - body = scheme_resolve_expr(body, linfo); - if (last) - ((Scheme_Let_One *)last)->body = body; - else { - first = body; - } - - if (max_let_depth < linfo->max_let_depth + frame_size) - max_let_depth = linfo->max_let_depth + frame_size; - - if (info->max_let_depth < max_let_depth) - info->max_let_depth = max_let_depth; - - scheme_merge_resolve_tl_map(info, linfo); - - /* Check for (let ([x ]) ( x)) at end, and change to - ( ). This transformation is more generally performed - at the optimization layer, the cocde here pre-dates the mode general - optimzation, and we keep it just in case. The simple case is easy here, - because the local-variable offsets in do not change (as long as - doesn't access the stack). */ - last_body = NULL; - body = first; - while (1) { - if (!SAME_TYPE(SCHEME_TYPE(body), scheme_let_one_type)) - break; - if (!SAME_TYPE(SCHEME_TYPE(((Scheme_Let_One *)body)->body), scheme_let_one_type)) - break; - last_body = body; - body = ((Scheme_Let_One *)body)->body; - } - if (SAME_TYPE(SCHEME_TYPE(body), scheme_let_one_type)) { - if (SAME_TYPE(SCHEME_TYPE(((Scheme_Let_One *)body)->body), scheme_application2_type)) { - Scheme_App2_Rec *app = (Scheme_App2_Rec *)((Scheme_Let_One *)body)->body; - if (SAME_TYPE(SCHEME_TYPE(app->rand), scheme_local_type) - && (SCHEME_LOCAL_POS(app->rand) == 1)) { - if ((SCHEME_TYPE(app->rator) > _scheme_values_types_) - && !scheme_wants_flonum_arguments(app->rator, 0, 1)) { - /* Move to app, and drop let-one: */ - app->rand = ((Scheme_Let_One *)body)->value; - scheme_reset_app2_eval_type(app); - if (last_body) - ((Scheme_Let_One *)last_body)->body = (Scheme_Object *)app; - else - first = (Scheme_Object *)app; - } - } - } - } - - return first; - } else { - /* Maybe some multi-binding lets, but all of them are unused - and the RHSes are omittable? This can happen with auto-generated - code. */ - int total = 0, j; - - clv = (Scheme_Compiled_Let_Value *)head->body; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - total += clv->count; - for (j = clv->count; j--; ) { - if (clv->flags[j] & SCHEME_WAS_USED) - break; - } - if (j >= 0) - break; - if (!scheme_omittable_expr(clv->value, clv->count, -1, 0, NULL, -1)) - break; - } - if (i < 0) { - /* All unused and omittable */ - linfo = scheme_resolve_info_extend(info, 0, total, 0); - first = scheme_resolve_expr((Scheme_Object *)clv, linfo); - if (info->max_let_depth < linfo->max_let_depth) - info->max_let_depth = linfo->max_let_depth; - scheme_merge_resolve_tl_map(info, linfo); - return first; - } - } - } - - num_skips = 0; - clv = (Scheme_Compiled_Let_Value *)head->body; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) - num_skips++; - } - - /* First assume that all letrec-bound procedures can be lifted to empty closures. - Then try assuming that all letrec-bound procedures can be at least lifted. - Then fall back to assuming no lifts. */ - - linfo = 0; - for (resolve_phase = ((num_rec_procs && !rec_proc_nonapply) ? 0 : 2); resolve_phase < 3; resolve_phase++) { - - /* Don't try plain lifting if top level is not available: */ - if ((resolve_phase == 1) && !scheme_resolve_is_toplevel_available(info)) - resolve_phase = 2; - - if (resolve_phase < 2) { - linfo = scheme_resolve_info_extend(info, head->count - num_rec_procs - num_skips, head->count, head->count); - lifted_recs = MALLOC_N(Scheme_Object *, num_rec_procs); - } else { - linfo = scheme_resolve_info_extend(info, head->count - num_skips, head->count, head->count); - lifted_recs = NULL; - } - - if (post_bind) - val_linfo = scheme_resolve_info_extend(info, head->count - num_skips, 0, 0); - else - val_linfo = linfo; - - /* Build mapping of compile-time indices to run-time indices, shuffling - letrecs to fall together in the shallowest part. Also determine - and initialize lifts for recursive procedures. Generating lift information - requires an iteration. */ - clv = (Scheme_Compiled_Let_Value *)head->body; - pos = ((resolve_phase < 2) ? 0 : num_rec_procs); - rpos = 0; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - int j; - - opos = clv->position; - - if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { - /* skipped */ - scheme_resolve_info_add_mapping(linfo, opos, 0, 0, NULL); - } else { - for (j = 0; j < clv->count; j++) { - int p, skip; - Scheme_Object *lift; - - skip = 0; - if (num_rec_procs - && (clv->count == 1) - && scheme_is_compiled_procedure(clv->value, 0, 0)) { - if (resolve_phase == 0) { - lift = scheme_resolve_generate_stub_closure(); - lifted_recs[rpos] = lift; - p = 0; - } else if (resolve_phase == 1) { - lift = scheme_resolve_generate_stub_lift(); - lifted_recs[rpos] = lift; - p = 0; - } else { - lift = NULL; - p = rpos; - } - rpos++; - } else { - p = pos++; - lift = NULL; - } - - scheme_resolve_info_add_mapping(linfo, opos, p, - ((recbox - || (clv->flags[j] & SCHEME_WAS_SET_BANGED)) - ? SCHEME_INFO_BOXED - : 0), - lift); - - opos++; - } - } - } - - if (resolve_phase < 2) { - /* Given the assumption that all are closed/lifted, compute - actual lift info. We have to iterate if there are - conversions, because a conversion can trigger another - conversion. If the conversion changes for an item, it's - always by adding more conversion arguments. */ - int converted; - do { - clv = (Scheme_Compiled_Let_Value *)head->body; - rpos = 0; - converted = 0; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - opos = clv->position; - if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { - /* skipped */ - } else if ((clv->count == 1) - && scheme_is_compiled_procedure(clv->value, 0, 0)) { - Scheme_Object *lift, *old_lift; - int old_convert_count; - - old_lift = lifted_recs[rpos]; - old_convert_count = get_convert_arg_count(old_lift); - - lift = scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 1, - (resolve_phase ? NULL : old_lift)); - - if (is_closed_reference(lift) - || (is_lifted_reference(lift) && resolve_phase)) { - if (!SAME_OBJ(old_lift, lift)) - scheme_resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift); - lifted_recs[rpos] = lift; - if (get_convert_arg_count(lift) != old_convert_count) - converted = 1; - } else { - lifted_recs = NULL; - converted = 0; - break; - } - rpos++; - } - } - } while (converted); - - if (lifted_recs) { - /* All can be closed or lifted --- and some may be converted. - For the converted ones, the argument conversion is right. For - lifted ones, we need to generate the actual offset. For fully - closed ones, we need the actual closure. - - If we succeeded with resolve_phase == 0, then all can be - fully closed. We need to resolve again with the stub - closures in place, and the mutate the stub closures with - the actual closure info. - - If we succeeded with resolve_phase == 1, then we need - actual lift offsets before resolving procedure bodies. - Also, we need to fix up the stub closures. */ - clv = (Scheme_Compiled_Let_Value *)head->body; - rpos = 0; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - opos = clv->position; - if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { - /* skipped */ - } else if ((clv->count == 1) && scheme_is_compiled_procedure(clv->value, 0, 0)) { - Scheme_Object *lift; - lift = lifted_recs[rpos]; - if (is_closed_reference(lift)) { - (void)scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lift); - /* lift is the final result; this result might be - referenced in the body of closures already, or in - not-yet-closed functions. If no one uses the result - via linfo, then the code was dead and it will get - GCed. */ - clv->value = NULL; /* inidicates that there's nothing more to do with the expr */ - } else { - lift = scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 2, NULL); - /* need to resolve one more time for the body of the lifted function */ - } - scheme_resolve_info_adjust_mapping(linfo, opos, rpos, 0, lift); - lifted_recs[rpos] = lift; - rpos++; - } - } - - break; /* don't need to iterate */ - } - } - } - - extra_alloc = 0; - - if (num_rec_procs) { - if (!lifted_recs) { - Scheme_Object **sa; - letrec = MALLOC_ONE_TAGGED(Scheme_Letrec); - letrec->so.type = scheme_letrec_type; - letrec->count = num_rec_procs; - sa = MALLOC_N(Scheme_Object *, num_rec_procs); - letrec->procs = sa; - } else { - extra_alloc = -num_rec_procs; - letrec = NULL; - } - } else - letrec = NULL; - - /* Resolve values: */ - boxes = scheme_null; - clv = (Scheme_Compiled_Let_Value *)head->body; - rpos = 0; - for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) { - opos = clv->position; - if ((clv->count == 1) && !(clv->flags[0] & SCHEME_WAS_USED)) { - /* skipped */ - } else { - int isproc; - Scheme_Object *expr; - if (!clv->value) - isproc = 1; - else if (clv->count == 1) - isproc = scheme_is_compiled_procedure(clv->value, 0, 0); - else - isproc = 0; - if (num_rec_procs && isproc) { - if (!lifted_recs) { - expr = scheme_resolve_closure_compilation(clv->value, val_linfo, 0, 0, 0, NULL); - letrec->procs[rpos++] = expr; - } else { - if (!is_closed_reference(lifted_recs[rpos])) { - /* Side-effect is to install lifted function: */ - (void)scheme_resolve_closure_compilation(clv->value, val_linfo, 1, 1, 0, lifted_recs[rpos]); - } - rpos++; - } - } else { - int j; - Scheme_Object *one_lifted; - - if (!clv->count) - expr = drop_zero_value_return(clv->value); - else - expr = NULL; - - if (expr) { - /* Change a `[() (begin expr (values))]' clause, - which can be generated by internal-definition expansion, - into a `begin' */ - expr = scheme_resolve_expr(expr, val_linfo); - expr = scheme_make_sequence_compilation(scheme_make_pair(expr, - scheme_make_pair(scheme_false, - scheme_null)), - 0); - - if (last) - last->body = expr; - else if (last_body) - SCHEME_PTR2_VAL(last_body) = expr; - else if (last_seq) - ((Scheme_Sequence *)last_seq)->array[1] = expr; - else - first = expr; - last = NULL; - last_body = NULL; - last_seq = expr; - } else { - expr = scheme_resolve_expr(clv->value, val_linfo); - - lv = MALLOC_ONE_TAGGED(Scheme_Let_Value); - if (last) - last->body = (Scheme_Object *)lv; - else if (last_body) - SCHEME_PTR2_VAL(last_body) = (Scheme_Object *)lv; - else if (last_seq) - ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)lv; - else - first = (Scheme_Object *)lv; - last = lv; - last_body = NULL; - last_seq = NULL; - - lv->iso.so.type = scheme_let_value_type; - lv->value = expr; - if (clv->count) { - int li; - li = scheme_resolve_info_lookup(linfo, clv->position, NULL, NULL, 0); - lv->position = li; - } else - lv->position = 0; - lv->count = clv->count; - SCHEME_LET_AUTOBOX(lv) = recbox; - - for (j = lv->count; j--; ) { - if (!recbox - && (scheme_resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) { - GC_CAN_IGNORE Scheme_Object *pos; - pos = scheme_make_integer(lv->position + j); - if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) { - /* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */ - Scheme_Object *boxenv; - - boxenv = scheme_alloc_object(); - boxenv->type = scheme_boxenv_type; - SCHEME_PTR1_VAL(boxenv) = pos; - SCHEME_PTR2_VAL(boxenv) = scheme_false; - - if (last) - last->body = boxenv; - else if (last_seq) - ((Scheme_Sequence *)last_seq)->array[1] = boxenv; - else - SCHEME_PTR2_VAL(last_body) = boxenv; - last = NULL; - last_body = boxenv; - last_seq = NULL; - } else { - /* For regular let, delay the boxing until all RHSs are - evaluated. */ - boxes = scheme_make_pair(pos, boxes); - } - } - } - } - } - } - } - - /* Resolve body: */ - body = scheme_resolve_expr(body, linfo); - - while (SCHEME_PAIRP(boxes)) { - /* See bangboxenv... */ - Scheme_Object *bcode; - bcode = scheme_alloc_object(); - bcode->type = scheme_boxenv_type; - SCHEME_PTR1_VAL(bcode) = SCHEME_CAR(boxes); - SCHEME_PTR2_VAL(bcode) = body; - body = bcode; - boxes = SCHEME_CDR(boxes); - } - - if (letrec) { - letrec->body = body; - if (last) - last->body = (Scheme_Object *)letrec; - else if (last_body) - SCHEME_PTR2_VAL(last_body) = (Scheme_Object *)letrec; - else if (last_seq) - ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)letrec; - else - first = (Scheme_Object *)letrec; - } else if (last) - last->body = body; - else if (last_body) - SCHEME_PTR2_VAL(last_body) = body; - else if (last_seq) - ((Scheme_Sequence *)last_seq)->array[1] = (Scheme_Object *)body; - else - first = body; - - if (head->count + extra_alloc - num_skips) { - int cnt; - - cnt = head->count + extra_alloc - num_skips; - - if (!recbox && (cnt == 1) - && (SAME_TYPE(SCHEME_TYPE(first), scheme_let_value_type)) - && (((Scheme_Let_Value *)first)->count == 1) - && (((Scheme_Let_Value *)first)->position == 0)) { - /* Simplify to let-one after all */ - Scheme_Let_One *lo; - int et; - - lo = MALLOC_ONE_TAGGED(Scheme_Let_One); - lo->iso.so.type = scheme_let_one_type; - lo->value = ((Scheme_Let_Value *)first)->value; - lo->body = ((Scheme_Let_Value *)first)->body; - - et = scheme_get_eval_type(lo->value); - SCHEME_LET_EVAL_TYPE(lo) = et; - - first = (Scheme_Object *)lo; - } else { - Scheme_Let_Void *lvd; - - lvd = MALLOC_ONE_TAGGED(Scheme_Let_Void); - lvd->iso.so.type = scheme_let_void_type; - lvd->body = first; - lvd->count = cnt; - SCHEME_LET_AUTOBOX(lvd) = recbox; - - first = (Scheme_Object *)lvd; - } - } - - if (info->max_let_depth < linfo->max_let_depth + head->count - num_skips + extra_alloc) - info->max_let_depth = linfo->max_let_depth + head->count - num_skips + extra_alloc; - scheme_merge_resolve_tl_map(info, linfo); - if (val_linfo) { - if (info->max_let_depth < val_linfo->max_let_depth + head->count - num_skips + extra_alloc) - info->max_let_depth = val_linfo->max_let_depth + head->count - num_skips + extra_alloc; - scheme_merge_resolve_tl_map(info, val_linfo); - } - - return first; -} - -static Scheme_Object * -gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname, - int star, int recursive, int multi, Scheme_Compile_Info *rec, int drec, - Scheme_Comp_Env *frame_already) -{ - Scheme_Object *bindings, *l, *binding, *name, **names, *forms, *defname; - int num_clauses, num_bindings, i, j, k, m, pre_k; - Scheme_Comp_Env *frame, *env, *rhs_env; - Scheme_Compile_Info *recs; - Scheme_Object *first = NULL; - Scheme_Compiled_Let_Value *last = NULL, *lv; - DupCheckRecord r; - int rec_env_already = rec[drec].env_already; - int rev_bind_order = recursive; - int post_bind = !recursive && !star; - - i = scheme_stx_proper_list_length(form); - if (i < 3) - scheme_wrong_syntax(NULL, NULL, form, (!i ? "bad syntax (empty body)" : NULL)); - - bindings = SCHEME_STX_CDR(form); - bindings = SCHEME_STX_CAR(bindings); - num_clauses = scheme_stx_proper_list_length(bindings); - - if (num_clauses < 0) - scheme_wrong_syntax(NULL, bindings, form, NULL); - - scheme_rec_add_certs(rec, drec, form); - - forms = SCHEME_STX_CDR(form); - forms = SCHEME_STX_CDR(forms); - forms = scheme_datum_to_syntax(forms, form, form, 0, 0); - - if (!num_clauses) { - env = scheme_no_defines(origenv); - - name = scheme_check_name_property(form, rec[drec].value_name); - rec[drec].value_name = name; - - return scheme_compile_sequence(forms, env, rec, drec); - } - - if (multi) { - num_bindings = 0; - l = bindings; - while (!SCHEME_STX_NULLP(l)) { - Scheme_Object *clause, *names, *rest; - int num_names; - - clause = SCHEME_STX_CAR(l); - - if (!SCHEME_STX_PAIRP(clause)) - rest = NULL; - else { - rest = SCHEME_STX_CDR(clause); - if (!SCHEME_STX_PAIRP(rest)) - rest = NULL; - else { - rest = SCHEME_STX_CDR(rest); - if (!SCHEME_STX_NULLP(rest)) - rest = NULL; - } - } - if (!rest) - scheme_wrong_syntax(NULL, clause, form, NULL); - - names = SCHEME_STX_CAR(clause); - - num_names = scheme_stx_proper_list_length(names); - if (num_names < 0) - scheme_wrong_syntax(NULL, names, form, NULL); - - num_bindings += num_names; - - l = SCHEME_STX_CDR(l); - } - } else - num_bindings = num_clauses; - - - names = MALLOC_N(Scheme_Object *, num_bindings); - if (frame_already) - frame = frame_already; - else { - frame = scheme_new_compilation_frame(num_bindings, - (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), - origenv, - rec[drec].certs); - if (rec_env_already) - frame_already = frame; - } - env = frame; - if (post_bind) - rhs_env = scheme_no_defines(origenv); - else - rhs_env = env; - - recs = MALLOC_N_RT(Scheme_Compile_Info, (num_clauses + 1)); - - defname = rec[drec].value_name; - scheme_compile_rec_done_local(rec, drec); - scheme_init_compile_recs(rec, drec, recs, num_clauses + 1); - - defname = scheme_check_name_property(form, defname); - - if (!star && !frame_already) { - scheme_begin_dup_symbol_check(&r, env); - } - - /* For `letrec', we bind the first set of identifiers at the deepest - position. That order makes it easier to peel off a prefix into a - separate `letrec'. For `let' and `let*', the first set of - identifiers is at the shallowest position. */ - - if (rev_bind_order) - k = num_bindings; - else - k = 0; - - for (i = 0; i < num_clauses; i++) { - if (!SCHEME_STX_PAIRP(bindings)) - scheme_wrong_syntax(NULL, bindings, form, NULL); - binding = SCHEME_STX_CAR(bindings); - if (!SCHEME_STX_PAIRP(binding) || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(binding))) - scheme_wrong_syntax(NULL, binding, form, NULL); - - { - Scheme_Object *rest; - rest = SCHEME_STX_CDR(binding); - if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) - scheme_wrong_syntax(NULL, binding, form, NULL); - } - - if (rev_bind_order) { - if (multi) { - name = SCHEME_STX_CAR(binding); - while (!SCHEME_STX_NULLP(name)) { - name = SCHEME_STX_CDR(name); - k--; - } - } else - k--; - } - - pre_k = k; - - name = SCHEME_STX_CAR(binding); - if (multi) { - while (!SCHEME_STX_NULLP(name)) { - Scheme_Object *n; - n = SCHEME_STX_CAR(name); - names[k] = n; - scheme_check_identifier(NULL, names[k], NULL, env, form); - k++; - name = SCHEME_STX_CDR(name); - } - - for (j = pre_k; j < k; j++) { - for (m = j + 1; m < k; m++) { - if (scheme_stx_bound_eq(names[m], names[j], scheme_make_integer(env->genv->phase))) - scheme_wrong_syntax(NULL, NULL, form, - "multiple bindings of `%S' in the same clause", - SCHEME_STX_SYM(names[m])); - } - } - } else { - scheme_check_identifier(NULL, name, NULL, env, form); - names[k++] = name; - } - - if (!star && !frame_already) { - for (m = pre_k; m < k; m++) { - scheme_dup_symbol_check(&r, NULL, names[m], "binding", form); - } - } - - lv = MALLOC_ONE_TAGGED(Scheme_Compiled_Let_Value); - lv->iso.so.type = scheme_compiled_let_value_type; - if (!last) - first = (Scheme_Object *)lv; - else - last->body = (Scheme_Object *)lv; - last = lv; - lv->count = (k - pre_k); - lv->position = pre_k; - - if (lv->count == 1) - recs[i].value_name = SCHEME_STX_SYM(names[pre_k]); - - if (!recursive) { - Scheme_Object *ce, *rhs; - rhs = SCHEME_STX_CDR(binding); - rhs = SCHEME_STX_CAR(rhs); - rhs = scheme_add_env_renames(rhs, env, origenv); - ce = scheme_compile_expr(rhs, rhs_env, recs, i); - lv->value = ce; - } else { - Scheme_Object *rhs; - rhs = SCHEME_STX_CDR(binding); - rhs = SCHEME_STX_CAR(rhs); - lv->value = rhs; - } - - if (star || recursive) { - for (m = pre_k; m < k; m++) { - scheme_add_compilation_binding(m, names[m], frame); - } - } - - bindings = SCHEME_STX_CDR(bindings); - - if (rev_bind_order) - k = pre_k; - } - - if (!star && !recursive) { - for (i = 0; i < num_bindings; i++) { - scheme_add_compilation_binding(i, names[i], frame); - } - } - - if (recursive) { - lv = (Scheme_Compiled_Let_Value *)first; - for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { - Scheme_Object *ce, *rhs; - rhs = lv->value; - rhs = scheme_add_env_renames(rhs, env, origenv); - ce = scheme_compile_expr(rhs, env, recs, i); - lv->value = ce; - - /* Record the fact that this binding doesn't use any or later - bindings in the same set. The `let' optimizer and resolver - break bindings into smaller sets based on this - information. */ - if (!scheme_env_check_reset_any_use(env) - && !might_invoke_call_cc(ce)) - SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_USES; - else if (!scheme_env_min_use_below(env, lv->position)) - SCHEME_CLV_FLAGS(lv) |= SCHEME_CLV_NO_GROUP_LATER_USES; - } - } - - recs[num_clauses].value_name = defname ? SCHEME_STX_SYM(defname) : NULL; - { - Scheme_Object *cs; - forms = scheme_add_env_renames(forms, env, origenv); - cs = scheme_compile_sequence(forms, env, recs, num_clauses); - last->body = cs; - } - - /* Save flags: */ - lv = (Scheme_Compiled_Let_Value *)first; - for (i = 0; i < num_clauses; i++, lv = (Scheme_Compiled_Let_Value *)lv->body) { - int *flags; - flags = scheme_env_get_flags(env, lv->position, lv->count); - lv->flags = flags; - } - - { - Scheme_Let_Header *head; - - head = MALLOC_ONE_TAGGED(Scheme_Let_Header); - head->iso.so.type = scheme_compiled_let_void_type; - head->body = first; - head->count = num_bindings; - head->num_clauses = num_clauses; - SCHEME_LET_FLAGS(head) = ((recursive ? SCHEME_LET_RECURSIVE : 0) - | (star ? SCHEME_LET_STAR : 0)); - - first = (Scheme_Object *)head; - } - - scheme_merge_compile_recs(rec, drec, recs, num_clauses + 1); - - return first; -} - -static Scheme_Object * -do_let_expand(Scheme_Object *form, Scheme_Comp_Env *origenv, Scheme_Expand_Info *erec, int drec, - const char *formname, int letrec, int multi, int letstar, - Scheme_Comp_Env *env_already) -{ - Scheme_Object *vars, *body, *first, *last, *name, *v, *vs, *vlist, *boundname; - Scheme_Comp_Env *use_env, *env; - Scheme_Expand_Info erec1; - DupCheckRecord r; - int rec_env_already = erec[drec].env_already; - - vars = SCHEME_STX_CDR(form); - - if (!SCHEME_STX_PAIRP(vars)) - scheme_wrong_syntax(NULL, NULL, form, NULL); - - body = SCHEME_STX_CDR(vars); - vars = SCHEME_STX_CAR(vars); - - if (!SCHEME_STX_PAIRP(body)) - scheme_wrong_syntax(NULL, NULL, form, (SCHEME_STX_NULLP(body) - ? "bad syntax (empty body)" - : NULL)); - - boundname = scheme_check_name_property(form, erec[drec].value_name); - erec[drec].value_name = boundname; - - scheme_rec_add_certs(erec, drec, form); - - if (letstar) { - if (!SCHEME_STX_NULLP(vars)) { - Scheme_Object *a, *vr; - - if (!SCHEME_STX_PAIRP(vars)) - scheme_wrong_syntax(NULL, vars, form, NULL); - - a = SCHEME_STX_CAR(vars); - vr = SCHEME_STX_CDR(vars); - - first = let_values_symbol; - first = scheme_datum_to_syntax(first, form, scheme_sys_wraps(origenv), 0, 0); - - if (SCHEME_STX_NULLP(vr)) { - /* Don't create redundant empty let form */ - } else { - last = let_star_values_symbol; - last = scheme_datum_to_syntax(last, form, scheme_sys_wraps(origenv), 0, 0); - body = cons(cons(last, cons(vr, body)), - scheme_null); - } - - body = cons(first, - cons(cons(a, scheme_null), - body)); - } else { - first = scheme_datum_to_syntax(let_values_symbol, form, scheme_sys_wraps(origenv), 0, 0); - body = cons(first, cons(scheme_null, body)); - } - - body = scheme_datum_to_syntax(body, form, form, 0, -1); - - first = SCHEME_STX_CAR(form); - body = scheme_stx_track(body, form, first); - - if (erec[drec].depth > 0) - --erec[drec].depth; - - if (!erec[drec].depth) - return body; - else { - env = scheme_no_defines(origenv); - return scheme_expand_expr(body, env, erec, drec); - } - } - - /* Note: no more letstar handling needed after this point */ - if (!env_already && !rec_env_already) - scheme_begin_dup_symbol_check(&r, origenv); - - vlist = scheme_null; - vs = vars; - while (SCHEME_STX_PAIRP(vs)) { - Scheme_Object *v2; - v = SCHEME_STX_CAR(vs); - if (SCHEME_STX_PAIRP(v)) - v2 = SCHEME_STX_CDR(v); - else - v2 = scheme_false; - if (!SCHEME_STX_PAIRP(v2) || !SCHEME_STX_NULLP(SCHEME_STX_CDR(v2))) - scheme_wrong_syntax(NULL, v, form, NULL); - - name = SCHEME_STX_CAR(v); - - { - DupCheckRecord r2; - Scheme_Object *names = name; - if (!env_already && !rec_env_already) - scheme_begin_dup_symbol_check(&r2, origenv); - while (SCHEME_STX_PAIRP(names)) { - name = SCHEME_STX_CAR(names); - - scheme_check_identifier(NULL, name, NULL, origenv, form); - vlist = cons(name, vlist); - - if (!env_already && !rec_env_already) { - scheme_dup_symbol_check(&r2, NULL, name, "clause binding", form); - scheme_dup_symbol_check(&r, NULL, name, "binding", form); - } - - names = SCHEME_STX_CDR(names); - } - if (!SCHEME_STX_NULLP(names)) - scheme_wrong_syntax(NULL, names, form, NULL); - } - - vs = SCHEME_STX_CDR(vs); - } - - if (!SCHEME_STX_NULLP(vs)) - scheme_wrong_syntax(NULL, vs, form, NULL); - - if (env_already) - env = env_already; - else - env = scheme_add_compilation_frame(vlist, - origenv, - (rec_env_already ? SCHEME_INTDEF_SHADOW : 0), - erec[drec].certs); - - if (letrec) - use_env = env; - else - use_env = scheme_no_defines(origenv); - - /* Pass 1: Rename */ - - first = last = NULL; - vs = vars; - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *rhs; - - v = SCHEME_STX_CAR(vars); - - /* Make sure names gets their own renames: */ - name = SCHEME_STX_CAR(v); - name = scheme_add_env_renames(name, env, origenv); - - rhs = SCHEME_STX_CDR(v); - rhs = SCHEME_STX_CAR(rhs); - rhs = scheme_add_env_renames(rhs, use_env, origenv); - - v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); - v = cons(v, scheme_null); - - if (!first) - first = v; - else - SCHEME_CDR(last) = v; - - last = v; - vars = SCHEME_STX_CDR(vars); - } - if (!first) { - first = scheme_null; - } - vars = first; - - body = scheme_datum_to_syntax(body, form, form, 0, 0); - body = scheme_add_env_renames(body, env, origenv); - SCHEME_EXPAND_OBSERVE_LET_RENAMES(erec[drec].observer, vars, body); - - /* Pass 2: Expand */ - - first = last = NULL; - while (SCHEME_STX_PAIRP(vars)) { - Scheme_Object *rhs, *rhs_name; - - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - - v = SCHEME_STX_CAR(vars); - - name = SCHEME_STX_CAR(v); - rhs = SCHEME_STX_CDR(v); - rhs = SCHEME_STX_CAR(rhs); - - if (SCHEME_STX_PAIRP(name) && SCHEME_STX_NULLP(SCHEME_STX_CDR(name))) { - rhs_name = SCHEME_STX_CAR(name); - } else { - rhs_name = scheme_false; - } - - scheme_init_expand_recs(erec, drec, &erec1, 1); - erec1.value_name = rhs_name; - rhs = scheme_expand_expr(rhs, use_env, &erec1, 0); - - v = scheme_datum_to_syntax(cons(name, cons(rhs, scheme_null)), v, v, 0, 1); - v = cons(v, scheme_null); - - if (!first) - first = v; - else - SCHEME_CDR(last) = v; - - last = v; - - vars = SCHEME_STX_CDR(vars); - } - - /* End Pass 2 */ - - if (!SCHEME_STX_NULLP(vars)) - scheme_wrong_syntax(NULL, vars, form, NULL); - - if (!first) - first = scheme_null; - - first = scheme_datum_to_syntax(first, vs, vs, 0, 1); - - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(erec[drec].observer); - scheme_init_expand_recs(erec, drec, &erec1, 1); - erec1.value_name = erec[drec].value_name; - body = scheme_expand_block(body, env, &erec1, 0); - - v = SCHEME_STX_CAR(form); - v = cons(v, cons(first, body)); - v = scheme_datum_to_syntax(v, form, form, 0, 2); - - return v; -} - -static Scheme_Object * -let_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LET_VALUES(erec[drec].observer); - return do_let_expand(form, env, erec, drec, "let-values", 0, 1, 0, NULL); -} - -static Scheme_Object * -let_star_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETSTAR_VALUES(erec[drec].observer); - return do_let_expand(form, env, erec, drec, "let*-values", 0, 1, 1, NULL); -} - -static Scheme_Object * -letrec_values_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(erec[drec].observer); - return do_let_expand(form, env, erec, drec, "letrec-values", 1, 1, 0, NULL); -} - - -static Scheme_Object * -let_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return gen_let_syntax(form, env, "let-values", 0, 0, 1, rec, drec, NULL); -} - -static Scheme_Object * -let_star_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return gen_let_syntax(form, env, "let*-values", 1, 0, 1, rec, drec, NULL); -} - -static Scheme_Object * -letrec_values_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return gen_let_syntax(form, env, "letrec-values", 0, 1, 1, rec, drec, NULL); -} - -/**********************************************************************/ -/* begin, begin0, implicit begins */ -/**********************************************************************/ - -Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, - Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ -#if 0 - /* This attempt at a shortcut is wrong, because the sole expression might expand - to a `begin' that needs to be spliced into an internal-definition context. */ - try_again: - - if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { - /* If it's a begin, we have to check some more... */ - Scheme_Object *first, *val; - - first = SCHEME_STX_CAR(forms); - first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL); - - if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) { - /* Flatten begin: */ - if (scheme_stx_proper_list_length(first) > 1) { - Scheme_Object *rest; - rest = scheme_flatten_begin(first, scheme_null); - first = scheme_datum_to_syntax(rest, first, first, 0, 2); - forms = first; - goto try_again; - } - } - - return scheme_compile_expr(first, env, rec, drec); - } -#endif - - if (scheme_stx_proper_list_length(forms) < 0) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, - scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), - "bad syntax (" IMPROPER_LIST_FORM ")"); - return NULL; - } else { - Scheme_Object *body; - body = scheme_compile_block(forms, env, rec, drec); - return scheme_make_sequence_compilation(body, 1); - } -} - -Scheme_Object *scheme_compiled_void() -{ - return scheme_void; -} - -Scheme_Object * -scheme_begin0_execute(Scheme_Object *obj) -{ - Scheme_Object *v, **mv; - int i, mc, apos; - - i = ((Scheme_Sequence *)obj)->count; - - v = _scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[0]); - i--; - if (SAME_OBJ(v, SCHEME_MULTIPLE_VALUES)) { - Scheme_Thread *p = scheme_current_thread; - mv = p->ku.multiple.array; - mc = p->ku.multiple.count; - if (SAME_OBJ(mv, p->values_buffer)) - p->values_buffer = NULL; - } else { - mv = NULL; - mc = 0; /* makes compilers happy */ - } - - apos = 1; - while (i--) { - (void)_scheme_eval_linked_expr_multi(((Scheme_Sequence *)obj)->array[apos++]); - } - - if (mv) { - Scheme_Thread *p = scheme_current_thread; - p->ku.multiple.array = mv; - p->ku.multiple.count = mc; - } - - return v; -} - -Scheme_Object *scheme_begin0_jit(Scheme_Object *data) -{ - Scheme_Sequence *seq = (Scheme_Sequence *)data, *seq2; - Scheme_Object *old, *naya = NULL; - int i, j, count; - - count = seq->count; - for (i = 0; i < count; i++) { - old = seq->array[i]; - naya = scheme_jit_expr(old); - if (!SAME_OBJ(old, naya)) - break; - } - - if (i >= count) - return data; - - seq2 = (Scheme_Sequence *)scheme_malloc_tagged(sizeof(Scheme_Sequence) - + (count - 1) - * sizeof(Scheme_Object *)); - seq2->so.type = scheme_begin0_sequence_type; - seq2->count = count; - for (j = 0; j < i; j++) { - seq2->array[j] = seq->array[j]; - } - seq2->array[i] = naya; - for (i++; i < count; i++) { - old = seq->array[i]; - naya = scheme_jit_expr(old); - seq2->array[i] = naya; - } - - return (Scheme_Object *)seq2; -} - -void scheme_begin0_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - Scheme_Sequence *seq = (Scheme_Sequence *)data; - int i; - - if (!SAME_TYPE(SCHEME_TYPE(seq), scheme_begin0_sequence_type) - && !SAME_TYPE(SCHEME_TYPE(seq), scheme_sequence_type)) - scheme_ill_formed_code(port); - - for (i = 0; i < seq->count; i++) { - scheme_validate_expr(port, seq->array[i], stack, tls, - depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - NULL, 0, i > 0, vc, 0, 0, procs); - } -} - -Scheme_Object * -scheme_begin0_optimize(Scheme_Object *obj, Optimize_Info *info, int context) -{ - int i, count; - - count = ((Scheme_Sequence *)obj)->count; - - for (i = 0; i < count; i++) { - Scheme_Object *le; - le = scheme_optimize_expr(((Scheme_Sequence *)obj)->array[i], info, - (!i - ? scheme_optimize_result_context(context) - : 0)); - ((Scheme_Sequence *)obj)->array[i] = le; - } - - /* Optimization of expression 0 has already set single_result */ - info->preserves_marks = 1; - - info->size += 1; - - return obj; -} - -Scheme_Object * -scheme_begin0_sfs(Scheme_Object *obj, SFS_Info *info) -{ - int i, cnt; - - cnt = ((Scheme_Sequence *)obj)->count; - - scheme_sfs_start_sequence(info, cnt, 0); - - for (i = 0; i < cnt; i++) { - Scheme_Object *le; - le = scheme_sfs_expr(((Scheme_Sequence *)obj)->array[i], info, -1); - ((Scheme_Sequence *)obj)->array[i] = le; - } - - return obj; -} - -static Scheme_Object * -do_begin_syntax(char *name, - Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, - int zero) -{ - Scheme_Object *forms, *body; - - forms = SCHEME_STX_CDR(form); - - if (SCHEME_STX_NULLP(forms)) { - if (!zero && scheme_is_toplevel(env)) - return scheme_compiled_void(); - scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)"); - return NULL; - } - - check_form(form, form); - - if (zero) - env = scheme_no_defines(env); - - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { - scheme_rec_add_certs(rec, drec, form); - forms = SCHEME_STX_CAR(forms); - return scheme_compile_expr(forms, env, rec, drec); - } - - if (!scheme_is_toplevel(env)) { - /* Not at top-level */ - if (zero) { - /* First expression is not part of the block: */ - Scheme_Compile_Info recs[2]; - Scheme_Object *first, *rest, *vname; - - vname = rec[drec].value_name; - scheme_compile_rec_done_local(rec, drec); - - vname = scheme_check_name_property(form, vname); - - scheme_rec_add_certs(rec, drec, form); - - scheme_init_compile_recs(rec, drec, recs, 2); - recs[0].value_name = vname; - - first = SCHEME_STX_CAR(forms); - first = scheme_compile_expr(first, env, recs, 0); - rest = SCHEME_STX_CDR(forms); - rest = scheme_compile_list(rest, env, recs, 1); - - scheme_merge_compile_recs(rec, drec, recs, 2); - - body = cons(first, rest); - } else { - Scheme_Object *v; - v = scheme_check_name_property(form, rec[drec].value_name); - rec[drec].value_name = v; - scheme_rec_add_certs(rec, drec, form); - - body = scheme_compile_list(forms, env, rec, drec); - } - } else { - /* Top level */ - scheme_rec_add_certs(rec, drec, form); - body = scheme_compile_list(forms, env, rec, drec); - } - - forms = scheme_make_sequence_compilation(body, zero ? -1 : 1); - - if (!zero - && SAME_TYPE(SCHEME_TYPE(forms), scheme_sequence_type) - && scheme_is_toplevel(env)) { - forms->type = scheme_splice_sequence_type; - return forms; - } - - return forms; -} - -static Scheme_Object * -begin_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_begin_syntax("begin", form, env, rec, drec, 0); -} - -static Scheme_Object * -begin0_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return do_begin_syntax("begin0", form, env, rec, drec, 1); -} - -static Scheme_Object * -stratified_body_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *body; - - check_form(form, form); - - body = SCHEME_STX_CDR(form); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = scheme_compile_stratified_block(body, env, rec, drec); - - if (SCHEME_NULLP(SCHEME_CDR(body))) - return SCHEME_CAR(body); - else - return scheme_make_sequence_compilation(body, 1); -} - -static Scheme_Object * -do_begin_expand(char *name, - Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, - int zero) -{ - Scheme_Object *form_name; - Scheme_Object *rest; - Scheme_Object *orig_form = form; - - check_form(form, form); - - form_name = SCHEME_STX_CAR(form); - - rest = SCHEME_STX_CDR(form); - - if (SCHEME_STX_NULLP(rest)) { - if (!zero && scheme_is_toplevel(env)) { - SCHEME_EXPAND_OBSERVE_ENTER_LIST(erec[drec].observer, form); - SCHEME_EXPAND_OBSERVE_EXIT_LIST(erec[drec].observer, form); - return form; - } - scheme_wrong_syntax(NULL, NULL, form, "bad syntax (empty form)"); - return NULL; - } - - if (zero) - env = scheme_no_defines(env); - - if (!scheme_is_toplevel(env)) { - /* Not at top-level: */ - if (zero) { - Scheme_Object *fst, *boundname; - Scheme_Expand_Info erec1; - scheme_rec_add_certs(erec, drec, form); - scheme_init_expand_recs(erec, drec, &erec1, 1); - boundname = scheme_check_name_property(form, erec[drec].value_name); - erec1.value_name = boundname; - erec[drec].value_name = scheme_false; - fst = SCHEME_STX_CAR(rest); - rest = SCHEME_STX_CDR(rest); - - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - fst = scheme_expand_expr(fst, env, &erec1, 0); - rest = scheme_datum_to_syntax(rest, form, form, 0, 0); - SCHEME_EXPAND_OBSERVE_NEXT(erec[drec].observer); - rest = scheme_expand_list(rest, env, erec, drec); - - form = cons(fst, rest); - } else { - Scheme_Object *boundname; - boundname = scheme_check_name_property(form, erec[drec].value_name); - erec[drec].value_name = boundname; - scheme_rec_add_certs(erec, drec, form); - - form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); -#if 0 - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(form))) - return SCHEME_STX_CAR(form); -#endif - } - } else { - /* Top level */ - scheme_rec_add_certs(erec, drec, form); - form = scheme_expand_list(scheme_datum_to_syntax(rest, form, form, 0, 0), - env, erec, drec); - } - - return scheme_datum_to_syntax(cons(form_name, form), - orig_form, orig_form, - 0, 2); -} - -static Scheme_Object * -begin_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN(erec[drec].observer); - return do_begin_expand("begin", form, env, erec, drec, 0); -} - -static Scheme_Object * -begin0_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_BEGIN0(erec[drec].observer); - return do_begin_expand("begin0", form, env, erec, drec, 1); -} - -static Scheme_Object * -stratified_body_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *body; - - SCHEME_EXPAND_OBSERVE_PRIM_STRATIFIED(erec[drec].observer); - - check_form(form, form); - - body = SCHEME_STX_CDR(form); - body = scheme_datum_to_syntax(body, form, form, 0, 0); - - body = scheme_expand_stratified_block(body, env, erec, drec); - - if (SCHEME_STX_NULLP(SCHEME_STX_CDR(body))) - return SCHEME_STX_CAR(body); - else { - body = cons(scheme_datum_to_syntax(begin_symbol, scheme_false, scheme_sys_wraps(env), 0, 0), - body); - return scheme_datum_to_syntax(body, form, form, 0, 0); - } -} - -/**********************************************************************/ -/* top-level splicing begin */ -/**********************************************************************/ - -static Scheme_Object *splice_one_expr(void *expr, int argc, Scheme_Object **argv) -{ - return _scheme_eval_linked_expr_multi((Scheme_Object *)expr); -} - -Scheme_Object *scheme_splice_execute(Scheme_Object *data) -{ - if (SAME_TYPE(SCHEME_TYPE(data), scheme_splice_sequence_type)) { - Scheme_Sequence *seq = (Scheme_Sequence *)data; - int i, cnt = seq->count - 1; - - for (i = 0; i < cnt; i++) { - (void)_scheme_call_with_prompt_multi(splice_one_expr, seq->array[i]); - } - - return _scheme_eval_linked_expr_multi(seq->array[cnt]); - } else { - /* sequence was optimized on read? */ - return _scheme_eval_linked_expr_multi(data); - } -} - -/**********************************************************************/ -/* #%non-module and #%expression */ -/**********************************************************************/ - -static Scheme_Object *check_single(Scheme_Object *form, Scheme_Comp_Env *top_only) -{ - Scheme_Object *rest; - - check_form(form, form); - - rest = SCHEME_STX_CDR(form); - if (!(SCHEME_STX_PAIRP(rest) && SCHEME_STX_NULLP(SCHEME_STX_CDR(rest)))) - scheme_wrong_syntax(NULL, NULL, form, "bad syntax (wrong number of parts)"); - - if (top_only && !scheme_is_toplevel(top_only)) - scheme_wrong_syntax(NULL, NULL, form, "illegal use (not at top-level)"); - - return SCHEME_STX_CAR(rest); -} - -static Scheme_Object * -single_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec, int top_only) -{ - scheme_rec_add_certs(rec, drec, form); - return scheme_compile_expr(check_single(form, top_only ? env: NULL), env, rec, drec); -} - -static Scheme_Object * -single_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec, - int top_only, int simplify) -{ - Scheme_Object *expr, *form_name; - - scheme_rec_add_certs(erec, drec, form); - - expr = check_single(form, top_only ? env : NULL); - expr = scheme_expand_expr(expr, env, erec, drec); - - form_name = SCHEME_STX_CAR(form); - - if (simplify && (erec[drec].depth == -1)) { - /* FIXME: this needs EXPAND_OBSERVE callbacks. */ - expr = scheme_stx_track(expr, form, form_name); - expr = scheme_stx_cert(expr, scheme_false, NULL, form, NULL, 1); - SCHEME_EXPAND_OBSERVE_TAG(erec[drec].observer,expr); - return expr; - } - - return scheme_datum_to_syntax(cons(form_name, cons(expr, scheme_null)), - form, form, - 0, 2); -} - -static Scheme_Object *expression_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - return single_syntax(form, scheme_no_defines(env), rec, drec, 0); -} - -static Scheme_Object *expression_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_EXPRESSION(erec[drec].observer); - return single_expand(form, scheme_no_defines(env), erec, drec, 0, - !(env->flags & SCHEME_TOPLEVEL_FRAME)); -} - - -/**********************************************************************/ -/* unquote, unquote-splicing */ -/**********************************************************************/ - -static Scheme_Object * -unquote_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - int len; - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); - - len = check_form(form, form); - if (len != 2) - bad_form(form, len); - - scheme_wrong_syntax(NULL, NULL, form, "not in quasiquote"); - return NULL; -} - -static Scheme_Object * -unquote_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return unquote_syntax(form, env, erec, drec); -} - -/**********************************************************************/ -/* quote-syntax */ -/**********************************************************************/ - -static Scheme_Object * -quote_syntax_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) -{ - int len; - Scheme_Object *stx; - - if (rec[drec].comp) - scheme_compile_rec_done_local(rec, drec); - - len = check_form(form, form); - if (len != 2) - bad_form(form, len); - - scheme_rec_add_certs(rec, drec, form); - - stx = SCHEME_STX_CDR(form); - stx = SCHEME_STX_CAR(stx); - - /* Push all certificates in the environment down to the syntax object. */ - stx = scheme_stx_add_inactive_certs(stx, rec[drec].certs); - if (env->genv->module && !rec[drec].no_module_cert) { - /* Also certify access to the enclosing module: */ - stx = scheme_stx_cert(stx, scheme_false, env->genv, NULL, NULL, 0); - } - - if (rec[drec].comp) { - return scheme_register_stx_in_prefix(stx, env, rec, drec); - } else { - Scheme_Object *fn; - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, cons(stx, scheme_null)), - form, - form, - 0, 2); - } -} - -static Scheme_Object * -quote_syntax_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_QUOTE_SYNTAX(erec[drec].observer); - return quote_syntax_syntax(form, env, erec, drec); -} - - -/**********************************************************************/ -/* define-syntaxes */ -/**********************************************************************/ - -static Scheme_Object *do_define_syntaxes_execute(Scheme_Object *expr, Scheme_Env *dm_env, int for_stx); - -static void *define_syntaxes_execute_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *form = p->ku.k.p1; - Scheme_Env *dm_env = (Scheme_Env *)p->ku.k.p2; - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - return do_define_syntaxes_execute(form, dm_env, p->ku.k.i1); -} - -static Scheme_Object * -do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx) -{ - Scheme_Thread *p = scheme_current_thread; - Resolve_Prefix *rp; - Scheme_Object *base_stack_depth, *dummy; - int depth; - Scheme_Comp_Env *rhs_env; - - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(form)[1]; - base_stack_depth = SCHEME_VEC_ELS(form)[2]; - - depth = SCHEME_INT_VAL(base_stack_depth) + rp->num_stxes + 1; - if (!scheme_check_runstack(depth)) { - p->ku.k.p1 = form; - - if (!dm_env) { - /* Need to get env before we enlarge the runstack: */ - dummy = SCHEME_VEC_ELS(form)[3]; - dm_env = scheme_environment_from_dummy(dummy); - } - p->ku.k.p2 = (Scheme_Object *)dm_env; - p->ku.k.i1 = for_stx; - - return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k); - } - - dummy = SCHEME_VEC_ELS(form)[3]; - - rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, SCHEME_TOPLEVEL_FRAME); - - if (!dm_env) - dm_env = scheme_environment_from_dummy(dummy); - - { - Scheme_Dynamic_State dyn_state; - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - Scheme_Object *result; - - scheme_prepare_exp_env(dm_env); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)dm_env->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, NULL, dm_env, dm_env->link_midx); - result = define_execute_with_dynamic_state(form, 4, for_stx ? 2 : 1, rp, dm_env, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - - return result; - } -} - -Scheme_Object * -scheme_define_syntaxes_execute(Scheme_Object *form) -{ - return do_define_syntaxes_execute(form, NULL, 0); -} - -Scheme_Object * -scheme_define_for_syntaxes_execute(Scheme_Object *form) -{ - return do_define_syntaxes_execute(form, NULL, 1); -} - -static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr, int jit) -{ - Resolve_Prefix *rp, *orig_rp; - Scheme_Object *naya, *rhs; - - rhs = SCHEME_VEC_ELS(expr)[0]; - if (jit) - naya = scheme_jit_expr(rhs); - else - naya = rhs; - - orig_rp = (Resolve_Prefix *)SCHEME_VEC_ELS(expr)[1]; - rp = scheme_prefix_eval_clone(orig_rp); - - if (SAME_OBJ(naya, rhs) - && SAME_OBJ(orig_rp, rp)) - return expr; - else { - expr = clone_vector(expr, 0, 1); - SCHEME_VEC_ELS(expr)[0] = naya; - SCHEME_VEC_ELS(expr)[1] = (Scheme_Object *)rp; - return expr; - } -} - -Scheme_Object *scheme_define_syntaxes_jit(Scheme_Object *expr) -{ - return do_define_syntaxes_jit(expr, 1); -} - -Scheme_Object *scheme_define_for_syntaxes_jit(Scheme_Object *expr) -{ - return do_define_syntaxes_jit(expr, 1); -} - -Scheme_Object *scheme_syntaxes_eval_clone(Scheme_Object *expr) -{ - return do_define_syntaxes_jit(expr, 0); -} - -static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, - int for_stx) -{ - Resolve_Prefix *rp; - Scheme_Object *name, *val, *base_stack_depth, *dummy; - int sdepth; - - if (!SCHEME_VECTORP(data) - || (SCHEME_VEC_SIZE(data) < 4)) - scheme_ill_formed_code(port); - - rp = (Resolve_Prefix *)SCHEME_VEC_ELS(data)[1]; - base_stack_depth = SCHEME_VEC_ELS(data)[2]; - sdepth = SCHEME_INT_VAL(base_stack_depth); - - if (!SAME_TYPE(rp->so.type, scheme_resolve_prefix_type) - || (sdepth < 0)) - scheme_ill_formed_code(port); - - dummy = SCHEME_VEC_ELS(data)[3]; - - if (!for_stx) { - int i, size; - size = SCHEME_VEC_SIZE(data); - for (i = 4; i < size; i++) { - name = SCHEME_VEC_ELS(data)[i]; - if (!SCHEME_SYMBOLP(name)) { - scheme_ill_formed_code(port); - } - } - } - - scheme_validate_toplevel(dummy, port, stack, tls, depth, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, - 0); - - if (!for_stx) { - scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); - } else { - /* Make a fake `define-values' to check with respect to the exp-time stack */ - val = clone_vector(data, 3, 1); - SCHEME_VEC_ELS(val)[0] = SCHEME_VEC_ELS(data)[0]; - scheme_validate_code(port, val, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); - } -} - -void scheme_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, 0); -} - -void scheme_define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, - char *stack, Validate_TLS tls, - int depth, int letlimit, int delta, - int num_toplevels, int num_stxes, int num_lifts, - void *tl_use_map, int result_ignored, - struct Validate_Clearing *vc, int tailpos, - Scheme_Hash_Tree *procs) -{ - do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, - num_toplevels, num_stxes, num_lifts, tl_use_map, 1); -} - -static Scheme_Object *do_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int for_stx) -{ - Scheme_Object *val; - Optimize_Info *einfo; - - val = SCHEME_VEC_ELS(data)[3]; - - einfo = scheme_optimize_info_create(); - if (info->inline_fuel < 0) - einfo->inline_fuel = -1; - - val = scheme_optimize_expr(val, einfo, 0); - - SCHEME_VEC_ELS(data)[3] = val; - - return data; -} - -Scheme_Object *scheme_define_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - return do_define_syntaxes_optimize(data, info, 0); -} - -Scheme_Object *scheme_define_for_syntaxes_optimize(Scheme_Object *data, Optimize_Info *info, int context) -{ - return do_define_syntaxes_optimize(data, info, 1); -} - -static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info, int for_stx) -{ - Comp_Prefix *cp; - Resolve_Prefix *rp; - Scheme_Object *names, *val, *base_stack_depth, *dummy, *vec; - Resolve_Info *einfo; - int len; - - cp = (Comp_Prefix *)SCHEME_VEC_ELS(data)[0]; - dummy = SCHEME_VEC_ELS(data)[1]; - names = SCHEME_VEC_ELS(data)[2]; - val = SCHEME_VEC_ELS(data)[3]; - - rp = scheme_resolve_prefix(1, cp, 1); - - dummy = scheme_resolve_expr(dummy, info); - - einfo = scheme_resolve_info_create(rp); - - if (for_stx) - names = scheme_resolve_list(names, einfo); - val = scheme_resolve_expr(val, einfo); - - rp = scheme_remap_prefix(rp, einfo); - - base_stack_depth = scheme_make_integer(einfo->max_let_depth); - - len = scheme_list_length(names); - - vec = scheme_make_vector(len + 4, NULL); - SCHEME_VEC_ELS(vec)[0] = val; - SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp; - SCHEME_VEC_ELS(vec)[2] = base_stack_depth; - SCHEME_VEC_ELS(vec)[3] = dummy; - - len = 4; - while (SCHEME_PAIRP(names)) { - SCHEME_VEC_ELS(vec)[len++] = SCHEME_CAR(names); - names = SCHEME_CDR(names); - } - - vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) + SCHEME_VEC_ELS(vec)[7] = scheme_true; return vec; } -Scheme_Object *scheme_define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj, Scheme_Object *insp) { - return do_define_syntaxes_resolve(data, info, 0); -} + Scheme_Object *vec; + int i; -Scheme_Object *scheme_define_for_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info) -{ - return do_define_syntaxes_resolve(data, info, 1); -} + if (!SCHEME_VECTORP(obj) + || (SCHEME_VEC_SIZE(obj) != 8)) + return NULL; -static Scheme_Object *do_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) -{ - Scheme_Object *e; - - if (!info->pass) { - int depth; - depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(data)[2]); - info = scheme_new_sfs_info(depth); - e = scheme_sfs(SCHEME_VEC_ELS(data)[0], info, depth); - SCHEME_VEC_ELS(data)[0] = e; + vec = scheme_make_vector(8, NULL); + for (i = 0; i < 8; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; } - return data; -} - -Scheme_Object *scheme_define_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) -{ - return do_define_syntaxes_sfs(data, info); -} - -Scheme_Object *scheme_define_for_syntaxes_sfs(Scheme_Object *data, SFS_Info *info) -{ - return do_define_syntaxes_sfs(data, info); -} - -static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) -{ - Scheme_Env *env = (Scheme_Env *)_env; - - return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL); -} - -static Scheme_Object * -do_define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec, int for_stx) -{ - Scheme_Object *names, *code, *dummy; - Scheme_Object *val, *vec; - Scheme_Comp_Env *exp_env; - Scheme_Compile_Info rec1; - - scheme_compile_rec_done_local(rec, drec); - scheme_default_compile_rec(rec, drec); - scheme_rec_add_certs(rec, drec, form); - - scheme_define_parse(form, &names, &code, 1, env, 0); - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - - if (!for_stx) - names = scheme_named_map_1(NULL, stx_val, names, (Scheme_Object *)env->genv); - - exp_env = scheme_new_comp_env(env->genv->exp_env, env->insp, 0); - - dummy = scheme_make_environment_dummy(env); - - rec1.comp = 1; - rec1.dont_mark_local_use = 0; - rec1.resolve_module_ids = 0; - rec1.no_module_cert = 0; - rec1.value_name = NULL; - rec1.certs = rec[drec].certs; - rec1.observer = NULL; - rec1.pre_unwrapped = 0; - rec1.env_already = 0; - rec1.comp_flags = rec[drec].comp_flags; - - if (for_stx) { - names = defn_targets_syntax(names, exp_env, &rec1, 0); - scheme_compile_rec_done_local(&rec1, 0); - } - - val = scheme_compile_expr_lift_to_let(code, exp_env, &rec1, 0); - - vec = scheme_make_vector(4, NULL); - SCHEME_VEC_ELS(vec)[0] = (Scheme_Object *)exp_env->prefix; - SCHEME_VEC_ELS(vec)[1] = dummy; - SCHEME_VEC_ELS(vec)[2] = names; - SCHEME_VEC_ELS(vec)[3] = val; - - vec->type = (for_stx ? scheme_define_for_syntax_type : scheme_define_syntaxes_type); + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) + SCHEME_VEC_ELS(vec)[7] = insp; + vec->type = scheme_free_id_info_type; + return vec; } -static Scheme_Object * -define_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_define_syntaxes_syntax(form, env, rec, drec, 0); -} - -static Scheme_Object * -define_for_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_define_syntaxes_syntax(form, env, rec, drec, 1); -} - -static Scheme_Object * -define_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - Scheme_Object *names, *code, *fpart, *fn; - - SCHEME_EXPAND_OBSERVE_PRIM_DEFINE_SYNTAXES(erec[drec].observer); - - scheme_prepare_exp_env(env->genv); - scheme_prepare_compile_env(env->genv->exp_env); - - scheme_define_parse(form, &names, &code, 1, env, 0); - - env = scheme_new_expand_env(env->genv->exp_env, env->insp, 0); - - scheme_rec_add_certs(erec, drec, form); - erec[drec].value_name = names; - fpart = scheme_expand_expr_lift_to_let(code, env, erec, drec); - - code = cons(fpart, scheme_null); - code = cons(names, code); - - fn = SCHEME_STX_CAR(form); - return scheme_datum_to_syntax(cons(fn, code), - form, form, - 0, 2); -} - -static Scheme_Object * -define_for_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - return define_syntaxes_expand(form, env, erec, drec); -} - -Scheme_Object *scheme_make_environment_dummy(Scheme_Comp_Env *env) -{ - /* Get a prefixed-based accessor for a dummy top-level bucket. It's - used to "link" to the right environment at run time. The #f as - a toplevel is handled in the prefix linker specially. */ - return scheme_register_toplevel_in_prefix(scheme_false, env, NULL, 0, 0); -} - -Scheme_Env *scheme_environment_from_dummy(Scheme_Object *dummy) -{ - Scheme_Prefix *toplevels; - Scheme_Bucket *b; - - toplevels = (Scheme_Prefix *)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(dummy)]; - b = (Scheme_Bucket *)toplevels->a[SCHEME_TOPLEVEL_POS(dummy)]; - return scheme_get_bucket_home(b); -} - -/**********************************************************************/ -/* letrec-syntaxes */ -/**********************************************************************/ - -static void *eval_letmacro_rhs_k(void); - -static Scheme_Object *eval_letmacro_rhs(Scheme_Object *a, Scheme_Comp_Env *rhs_env, - int max_let_depth, Resolve_Prefix *rp, - int phase, Scheme_Object *certs) -{ - Scheme_Object **save_runstack; - int depth; - - depth = max_let_depth + scheme_prefix_depth(rp); - if (!scheme_check_runstack(depth)) { - Scheme_Thread *p = scheme_current_thread; - p->ku.k.p1 = a; - p->ku.k.p2 = rhs_env; - p->ku.k.p3 = rp; - p->ku.k.p4 = certs; - p->ku.k.i1 = max_let_depth; - p->ku.k.i2 = phase; - return (Scheme_Object *)scheme_enlarge_runstack(depth, eval_letmacro_rhs_k); - } - - save_runstack = scheme_push_prefix(NULL, rp, NULL, NULL, phase, phase, rhs_env->genv); - - if (scheme_omittable_expr(a, 1, -1, 0, NULL, -1)) { - /* short cut */ - a = _scheme_eval_linked_expr_multi(a); - } else { - Scheme_Cont_Frame_Data cframe; - Scheme_Config *config; - Scheme_Dynamic_State dyn_state; - - scheme_prepare_exp_env(rhs_env->genv); - scheme_prepare_compile_env(rhs_env->genv->exp_env); - - config = scheme_extend_config(scheme_current_config(), - MZCONFIG_ENV, - (Scheme_Object *)rhs_env->genv->exp_env); - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config); - - scheme_set_dynamic_state(&dyn_state, rhs_env, NULL, scheme_false, certs, rhs_env->genv, rhs_env->genv->link_midx); - a = scheme_eval_linked_expr_multi_with_dynamic_state(a, &dyn_state); - - scheme_pop_continuation_frame(&cframe); - } - - scheme_pop_prefix(save_runstack); - - return a; -} - -static void *eval_letmacro_rhs_k(void) -{ - Scheme_Thread *p = scheme_current_thread; - Scheme_Object *a, *certs; - Scheme_Comp_Env *rhs_env; - int max_let_depth, phase; - Resolve_Prefix *rp; - - a = (Scheme_Object *)p->ku.k.p1; - rhs_env = (Scheme_Comp_Env *)p->ku.k.p2; - rp = (Resolve_Prefix *)p->ku.k.p3; - certs = (Scheme_Object *)p->ku.k.p4; - max_let_depth = p->ku.k.i1; - phase = p->ku.k.i2; - - p->ku.k.p1 = NULL; - p->ku.k.p2 = NULL; - p->ku.k.p3 = NULL; - p->ku.k.p4 = NULL; - - return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase, certs); -} - -void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, - Scheme_Env *exp_env, Scheme_Object *insp, - Scheme_Compile_Expand_Info *rec, int drec, - Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos, Scheme_Object *rename_rib) -{ - Scheme_Object **results, *l, *a_expr; - Scheme_Comp_Env *eenv; - Scheme_Object *certs; - Resolve_Prefix *rp; - Resolve_Info *ri; - Optimize_Info *oi; - int vc, nc, j, i; - Scheme_Compile_Expand_Info mrec; - - certs = rec[drec].certs; - eenv = scheme_new_comp_env(exp_env, insp, 0); - - /* First expand for expansion-observation */ - if (!rec[drec].comp) { - scheme_init_expand_recs(rec, drec, &mrec, 1); - SCHEME_EXPAND_OBSERVE_ENTER_BIND(rec[drec].observer); - a = scheme_expand_expr_lift_to_let(a, eenv, &mrec, 0); - } - - /* Then compile */ - mrec.comp = 1; - mrec.dont_mark_local_use = 0; - mrec.resolve_module_ids = 1; - mrec.no_module_cert = 1; - mrec.value_name = NULL; - mrec.certs = certs; - mrec.observer = NULL; - mrec.pre_unwrapped = 0; - mrec.env_already = 0; - mrec.comp_flags = rec[drec].comp_flags; - - a = scheme_compile_expr_lift_to_let(a, eenv, &mrec, 0); - - /* For internal defn, don't simplify as resolving, because the - expression may have syntax objects with a lexical rename that - is still being extended. - For letrec-syntaxes+values, don't simplify because it's too expensive. */ - rp = scheme_resolve_prefix(eenv->genv->phase, eenv->prefix, 0); - - oi = scheme_optimize_info_create(); - if (!(rec[drec].comp_flags & COMP_CAN_INLINE)) - oi->inline_fuel = -1; - a = scheme_optimize_expr(a, oi, 0); - - ri = scheme_resolve_info_create(rp); - a = scheme_resolve_expr(a, ri); - - rp = scheme_remap_prefix(rp, ri); - - /* To JIT: - if (ri->use_jit) a = scheme_jit_expr(a); - but it's not likely that a let-syntax-bound macro is going - to run lots of times, so JITting is probably not worth it. */ - - SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - - a_expr = a; - a = eval_letmacro_rhs(a_expr, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs); - - if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) { - vc = scheme_current_thread->ku.multiple.count; - results = scheme_current_thread->ku.multiple.array; - scheme_current_thread->ku.multiple.array = NULL; - if (SAME_OBJ(results, scheme_current_thread->values_buffer)) - scheme_current_thread->values_buffer = NULL; - } else { - vc = 1; - results = NULL; - } - - for (nc = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - nc++; - } - - if (vc != nc) { - Scheme_Object *name; - const char *symname; - - if (nc >= 1) { - name = SCHEME_STX_CAR(names); - name = SCHEME_STX_VAL(name); - } else - name = NULL; - symname = (name ? scheme_symbol_name(name) : ""); - - scheme_wrong_return_arity(where, - nc, vc, - (vc == 1) ? (Scheme_Object **)a : results, - "%s%s%s", - name ? "defining \"" : "0 names", - symname, - name ? ((nc == 1) ? "\"" : "\", ...") : ""); - } - - i = *_pos; - for (j = 0, l = names; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l), j++) { - Scheme_Object *name, *macro; - name = SCHEME_STX_CAR(l); - - macro = scheme_alloc_small_object(); - macro->type = scheme_macro_type; - if (vc == 1) - SCHEME_PTR_VAL(macro) = a; - else - SCHEME_PTR_VAL(macro) = results[j]; - - scheme_set_local_syntax(i++, name, macro, stx_env); - - if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { - /* Install a free-id=? rename */ - scheme_install_free_id_rename(name, scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), rename_rib, - scheme_make_integer(rhs_env->genv->phase)); - } - } - *_pos = i; - - SCHEME_EXPAND_OBSERVE_EXIT_BIND(rec[drec].observer); -} - -static Scheme_Object * -do_letrec_syntaxes(const char *where, - Scheme_Object *forms, Scheme_Comp_Env *origenv, - Scheme_Compile_Info *rec, int drec) -{ - Scheme_Object *form, *bindings, *var_bindings, *body, *v; - Scheme_Object *names_to_disappear; - Scheme_Comp_Env *stx_env, *var_env, *rhs_env; - int cnt, stx_cnt, var_cnt, i, j, depth, saw_var, env_already; - DupCheckRecord r; - - env_already = rec[drec].env_already; - - form = SCHEME_STX_CDR(forms); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - bindings = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - var_bindings = SCHEME_STX_CAR(form); - form = SCHEME_STX_CDR(form); - if (!SCHEME_STX_PAIRP(form)) - scheme_wrong_syntax(NULL, NULL, forms, NULL); - body = scheme_datum_to_syntax(form, forms, forms, 0, 0); - - scheme_rec_add_certs(rec, drec, forms); - - if (env_already) - stx_env = origenv; - else - stx_env = scheme_new_compilation_frame(0, 0, origenv, rec[drec].certs); - - rhs_env = stx_env; - - if (!SCHEME_STX_NULLP(bindings) && !SCHEME_STX_PAIRP(bindings)) { - scheme_wrong_syntax(NULL, bindings, forms, "bad syntax (not a binding sequence)"); - } else - check_form(bindings, forms); - if (!SCHEME_STX_NULLP(var_bindings) && !SCHEME_STX_PAIRP(var_bindings)) { - scheme_wrong_syntax(NULL, var_bindings, forms, "bad syntax (not a binding sequence)"); - } else - check_form(var_bindings, forms); - - cnt = stx_cnt = var_cnt = 0; - saw_var = 0; - - depth = rec[drec].depth; - - if (!rec[drec].comp && (depth <= 0) && (depth > -2)) - names_to_disappear = scheme_null; - else - names_to_disappear = NULL; - - if (!env_already) - scheme_begin_dup_symbol_check(&r, stx_env); - - /* Pass 1: Check and Rename */ - - for (i = 0; i < 2 ; i++) { - for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *l; - - a = SCHEME_STX_CAR(v); - if (!SCHEME_STX_PAIRP(a) - || !SCHEME_STX_PAIRP(SCHEME_STX_CDR(a))) - v = NULL; - else { - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - if (!SCHEME_STX_SYMBOLP(SCHEME_STX_CAR(l))) - break; - } - if (!SCHEME_STX_NULLP(l)) - v = NULL; - } - - if (v) { - Scheme_Object *rest; - rest = SCHEME_STX_CDR(a); - if (!SCHEME_STX_NULLP(SCHEME_STX_CDR(rest))) - v = NULL; - } - - if (!v) - scheme_wrong_syntax(NULL, a, forms, - "bad syntax (binding clause not an identifier sequence and expression)"); - - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (!env_already) { - scheme_check_identifier(where, a, NULL, stx_env, forms); - scheme_dup_symbol_check(&r, where, a, "binding", forms); - } - cnt++; - } - if (i) - saw_var = 1; - } - - if (!i) - stx_cnt = cnt; - else - var_cnt = cnt - stx_cnt; - } - - if (!env_already) - scheme_add_local_syntax(stx_cnt, stx_env); - - if (saw_var) { - var_env = scheme_new_compilation_frame(var_cnt, - (env_already ? SCHEME_INTDEF_SHADOW : 0), - stx_env, - rec[drec].certs); - } else - var_env = NULL; - - for (i = (env_already ? 1 : 0); i < (var_env ? 2 : 1) ; i++) { - cnt = (i ? var_cnt : stx_cnt); - if (cnt > 0) { - /* Add new syntax/variable names to the environment: */ - if (i) { - /* values in reverse order across clauses, in order within a clause */ - j = var_cnt; - } else - j = 0; - for (v = (i ? var_bindings : bindings); SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *l; - int pre_j; - - if (i) { - a = SCHEME_STX_CAR(v); - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - j--; - } - pre_j = j; - } else - pre_j = 0; - - a = SCHEME_STX_CAR(v); - for (l = SCHEME_STX_CAR(a); SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (i) { - /* In compile mode, this will get re-written by the letrec compiler. - But that's ok. We need it now for env_renames. */ - scheme_add_compilation_binding(j++, a, var_env); - } else - scheme_set_local_syntax(j++, a, NULL, stx_env); - } - - if (i) j = pre_j; - } - } - } - - if (names_to_disappear) { - for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *names; - - a = SCHEME_STX_CAR(v); - names = SCHEME_STX_CAR(a); - while (!SCHEME_STX_NULLP(names)) { - a = SCHEME_STX_CAR(names); - if (names_to_disappear) - names_to_disappear = cons(a, names_to_disappear); - names = SCHEME_STX_CDR(names); - } - } - } - - bindings = scheme_add_env_renames(bindings, stx_env, origenv); - if (var_env) - bindings = scheme_add_env_renames(bindings, var_env, origenv); - if (var_env) - var_bindings = scheme_add_env_renames(var_bindings, stx_env, origenv); - - body = scheme_add_env_renames(body, stx_env, origenv); - SCHEME_EXPAND_OBSERVE_LETREC_SYNTAXES_RENAMES(rec[drec].observer, bindings, var_bindings, body); - - scheme_prepare_exp_env(stx_env->genv); - scheme_prepare_compile_env(stx_env->genv->exp_env); - - if (!env_already) { - i = 0; - - for (v = bindings; SCHEME_STX_PAIRP(v); v = SCHEME_STX_CDR(v)) { - Scheme_Object *a, *names; - - SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - - a = SCHEME_STX_CAR(v); - names = SCHEME_STX_CAR(a); - a = SCHEME_STX_CDR(a); - a = SCHEME_STX_CAR(a); - - scheme_bind_syntaxes(where, names, a, - stx_env->genv->exp_env, - stx_env->insp, - rec, drec, - stx_env, rhs_env, - &i, NULL); - } - } - - SCHEME_EXPAND_OBSERVE_NEXT_GROUP(rec[drec].observer); - - if (!env_already && names_to_disappear) { - /* Need to add renaming for disappeared bindings. If they - originated for internal definitions, then we need both - pre-renamed and renamed, since some might have been - expanded to determine definitions. */ - Scheme_Object *l, *a, *pf = NULL, *pl = NULL; - - if (origenv->flags & SCHEME_FOR_INTDEF) { - for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - a = cons(a, scheme_null); - if (pl) - SCHEME_CDR(pl) = a; - else - pf = a; - pl = a; - } - } - - for (l = names_to_disappear; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) { - a = SCHEME_CAR(l); - a = scheme_add_env_renames(a, stx_env, origenv); - SCHEME_CAR(l) = a; - } - - if (pf) { - SCHEME_CDR(pl) = names_to_disappear; - names_to_disappear = pf; - } - } - - if (!var_env) { - var_env = scheme_require_renames(stx_env); - if (rec[drec].comp) { - v = scheme_check_name_property(forms, rec[drec].value_name); - rec[drec].value_name = v; - v = scheme_compile_block(body, var_env, rec, drec); - v = scheme_make_sequence_compilation(v, 1); - } else { - v = scheme_expand_block(body, var_env, rec, drec); - if ((depth >= 0) || (depth == -2)) { - Scheme_Object *formname; - formname = SCHEME_STX_CAR(forms); - v = cons(formname, cons(bindings, cons(var_bindings, v))); - } else { - v = cons(let_values_symbol, cons(scheme_null, v)); - } - - if (SCHEME_PAIRP(v)) - v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), - 0, 2); - - if (!((depth >= 0) || (depth == -2))) { - SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v); - } - } - } else { - /* Construct letrec-values expression: */ - v = cons(letrec_values_symbol, cons(var_bindings, body)); - v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2); - - if (rec[drec].comp) { - v = gen_let_syntax(v, stx_env, "letrec-values", 0, 1, 1, rec, drec, var_env); - } else { - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_VALUES(rec[drec].observer); - v = do_let_expand(v, stx_env, rec, drec, "letrec-values", 1, 1, 0, var_env); - - if ((depth >= 0) || (depth == -2)) { - /* Pull back out the pieces we want: */ - Scheme_Object *formname; - formname = SCHEME_STX_CAR(forms); - v = SCHEME_STX_CDR(v); - v = cons(formname, cons(bindings, v)); - v = scheme_datum_to_syntax(v, forms, scheme_sys_wraps(origenv), 0, 2); - } else { - SCHEME_EXPAND_OBSERVE_TAG(rec[drec].observer,v); - } - } - } - - /* Add the 'disappeared-binding property */ - if (names_to_disappear) - v = scheme_stx_property(v, disappeared_binding_symbol, names_to_disappear); - - return v; -} - -static Scheme_Object * -letrec_syntaxes_syntax(Scheme_Object *form, Scheme_Comp_Env *env, - Scheme_Compile_Info *rec, int drec) -{ - return do_letrec_syntaxes("letrec-syntaxes+values", form, env, rec, drec); -} - -static Scheme_Object * -letrec_syntaxes_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, int drec) -{ - SCHEME_EXPAND_OBSERVE_PRIM_LETREC_SYNTAXES_VALUES(erec[drec].observer); - - return do_letrec_syntaxes("letrec-syntaxes+values", form, env, erec, drec); -} - -/**********************************************************************/ -/* marshal/unmarshal */ -/**********************************************************************/ - -static Scheme_Object *write_let_value(Scheme_Object *obj) -{ - Scheme_Let_Value *lv; - - lv = (Scheme_Let_Value *)obj; - - return cons(scheme_make_integer(lv->count), - cons(scheme_make_integer(lv->position), - cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false, - cons(scheme_protect_quote(lv->value), - scheme_protect_quote(lv->body))))); -} - -static Scheme_Object *read_let_value(Scheme_Object *obj) -{ - Scheme_Let_Value *lv; - - lv = (Scheme_Let_Value *)scheme_malloc_tagged(sizeof(Scheme_Let_Value)); - lv->iso.so.type = scheme_let_value_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - lv->position = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - lv->value = SCHEME_CAR(obj); - lv->body = SCHEME_CDR(obj); - - return (Scheme_Object *)lv; -} - -static Scheme_Object *write_let_void(Scheme_Object *obj) -{ - Scheme_Let_Void *lv; - - lv = (Scheme_Let_Void *)obj; - - return cons(scheme_make_integer(lv->count), - cons(SCHEME_LET_AUTOBOX(lv) ? scheme_true : scheme_false, - scheme_protect_quote(lv->body))); -} - -static Scheme_Object *read_let_void(Scheme_Object *obj) -{ - Scheme_Let_Void *lv; - - lv = (Scheme_Let_Void *)scheme_malloc_tagged(sizeof(Scheme_Let_Void)); - lv->iso.so.type = scheme_let_void_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - lv->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - SCHEME_LET_AUTOBOX(lv) = SCHEME_TRUEP(SCHEME_CAR(obj)); - lv->body = SCHEME_CDR(obj); - - return (Scheme_Object *)lv; -} - -static Scheme_Object *write_let_one(Scheme_Object *obj) -{ - scheme_signal_error("let-one writer shouldn't be used"); - return NULL; -} - -static Scheme_Object *read_let_one(Scheme_Object *obj) -{ - return NULL; -} - -static Scheme_Object *write_letrec(Scheme_Object *obj) -{ - Scheme_Letrec *lr = (Scheme_Letrec *)obj; - Scheme_Object *l = scheme_null; - int i = lr->count; - - while (i--) { - l = cons(scheme_protect_quote(lr->procs[i]), l); - } - - return cons(scheme_make_integer(lr->count), - cons(scheme_protect_quote(lr->body), l)); -} - -static Scheme_Object *read_letrec(Scheme_Object *obj) -{ - Scheme_Letrec *lr; - int i, c; - Scheme_Object **sa; - - lr = MALLOC_ONE_TAGGED(Scheme_Letrec); - - lr->so.type = scheme_letrec_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - c = lr->count = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - - if (!SCHEME_PAIRP(obj)) return NULL; - lr->body = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - - sa = MALLOC_N(Scheme_Object*, c); - lr->procs = sa; - for (i = 0; i < c; i++) { - if (!SCHEME_PAIRP(obj)) return NULL; - lr->procs[i] = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - } - - return (Scheme_Object *)lr; -} - -static Scheme_Object *write_top(Scheme_Object *obj) -{ - Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)obj; - - if (!top->prefix) - scheme_raise_exn(MZEXN_FAIL, - "write: cannot marshal shared compiled code: %V", - obj); - - return cons(scheme_make_integer(top->max_let_depth), - cons((Scheme_Object *)top->prefix, - scheme_protect_quote(top->code))); -} - -static Scheme_Object *read_top(Scheme_Object *obj) -{ - Scheme_Compilation_Top *top; - - top = MALLOC_ONE_TAGGED(Scheme_Compilation_Top); - top->so.type = scheme_compilation_top_type; - if (!SCHEME_PAIRP(obj)) return NULL; - top->max_let_depth = SCHEME_INT_VAL(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - top->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); - top->code = SCHEME_CDR(obj); - - return (Scheme_Object *)top; -} - -static Scheme_Object *write_case_lambda(Scheme_Object *obj) -{ - Scheme_Case_Lambda *cl = (Scheme_Case_Lambda *)obj; - int i; - Scheme_Object *l; - - i = cl->count; - - l = scheme_null; - for (; i--; ) { - l = cons(cl->array[i], l); - } - - return cons((cl->name ? cl->name : scheme_null), - l); -} - -static Scheme_Object *read_case_lambda(Scheme_Object *obj) -{ - Scheme_Object *s, *a; - int count, i, all_closed = 1; - Scheme_Case_Lambda *cl; - - if (!SCHEME_PAIRP(obj)) return NULL; - s = SCHEME_CDR(obj); - for (count = 0; SCHEME_PAIRP(s); s = SCHEME_CDR(s)) { - count++; - } - - cl = (Scheme_Case_Lambda *) - scheme_malloc_tagged(sizeof(Scheme_Case_Lambda) - + (count - 1) * sizeof(Scheme_Object *)); - - cl->so.type = scheme_case_lambda_sequence_type; - cl->count = count; - cl->name = SCHEME_CAR(obj); - if (SCHEME_NULLP(cl->name)) - cl->name = NULL; - - s = SCHEME_CDR(obj); - for (i = 0; i < count; i++, s = SCHEME_CDR(s)) { - a = SCHEME_CAR(s); - cl->array[i] = a; - if (!SCHEME_PROCP(a)) { - if (!SAME_TYPE(SCHEME_TYPE(a), scheme_unclosed_procedure_type)) - return NULL; - all_closed = 0; - } - } - - if (all_closed) { - /* Empty closure: produce procedure value directly. - (We assume that this was generated by a direct write of - a case-lambda data record in print.c, and that it's not - in a CASE_LAMBDA_EXPD syntax record.) */ - return scheme_case_lambda_execute((Scheme_Object *)cl); - } - - return (Scheme_Object *)cl; -} - -static Scheme_Object *read_define_values(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = clone_vector(obj, 0, 0); - obj->type = scheme_define_values_type; - return obj; -} - -static Scheme_Object *write_define_values(Scheme_Object *obj) -{ - Scheme_Object *e; - - obj = clone_vector(obj, 0, 0); - e = scheme_protect_quote(SCHEME_VEC_ELS(obj)[0]); - SCHEME_VEC_ELS(obj)[0] = e; - - return obj; -} - -static Scheme_Object *read_define_syntaxes(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = clone_vector(obj, 0, 0); - obj->type = scheme_define_syntaxes_type; - return obj; -} - -static Scheme_Object *write_define_syntaxes(Scheme_Object *obj) -{ - return write_define_values(obj); -} - -static Scheme_Object *read_define_for_syntax(Scheme_Object *obj) -{ - if (!SCHEME_VECTORP(obj)) return NULL; - - obj = clone_vector(obj, 0, 0); - obj->type = scheme_define_for_syntax_type; - return obj; -} - -static Scheme_Object *write_define_for_syntax(Scheme_Object *obj) -{ - return write_define_values(obj); -} - -static Scheme_Object *read_set_bang(Scheme_Object *obj) -{ - Scheme_Set_Bang *sb; - - sb = MALLOC_ONE_TAGGED(Scheme_Set_Bang); - sb->so.type = scheme_set_bang_type; - - if (!SCHEME_PAIRP(obj)) return NULL; - sb->set_undef = SCHEME_TRUEP(SCHEME_CAR(obj)); - - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return NULL; - - sb->var = SCHEME_CAR(obj); - sb->val = SCHEME_CDR(obj); - - return (Scheme_Object *)sb; -} - -static Scheme_Object *write_set_bang(Scheme_Object *obj) -{ - Scheme_Set_Bang *sb = (Scheme_Set_Bang *)obj; - return scheme_make_pair((sb->set_undef ? scheme_true : scheme_false), - scheme_make_pair(sb->var, - scheme_protect_quote(sb->val))); -} - -Scheme_Object *write_varref(Scheme_Object *o) -{ - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_varref(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_varref_form_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} - -Scheme_Object *write_apply_values(Scheme_Object *o) -{ - return scheme_make_pair(scheme_protect_quote(SCHEME_PTR1_VAL(o)), - scheme_protect_quote(SCHEME_PTR2_VAL(o))); -} - -Scheme_Object *read_apply_values(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_apply_values_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} - -Scheme_Object *write_boxenv(Scheme_Object *o) -{ - return scheme_make_pair(SCHEME_PTR1_VAL(o), SCHEME_PTR2_VAL(o)); -} - -Scheme_Object *read_boxenv(Scheme_Object *o) -{ - Scheme_Object *data; - - if (!SCHEME_PAIRP(o)) return NULL; - - data = scheme_alloc_object(); - data->type = scheme_boxenv_type; - SCHEME_PTR1_VAL(data) = SCHEME_CAR(o); - SCHEME_PTR2_VAL(data) = SCHEME_CDR(o); - - return data; -} - -/**********************************************************************/ -/* expansion observer */ -/**********************************************************************/ - -/* RMC - * - Defines #%expobs module - * - current-expand-observe - * - ??? (other syntax observations) - */ - -void scheme_call_expand_observe(Scheme_Object *obs, int tag, Scheme_Object *obj) -{ - if (!SCHEME_PROCP(obs)) { - scheme_signal_error("internal error: expand-observer should never be non-procedure"); - } else { - Scheme_Object *buf[2]; - buf[0] = scheme_make_integer(tag); - if (obj) { - buf[1] = obj; - } else { - buf[1] = scheme_false; - } - scheme_apply(obs, 2, buf); - } -} - -static Scheme_Object * -current_expand_observe(int argc, Scheme_Object **argv) -{ - return scheme_param_config("current-expand-observe", - scheme_make_integer(MZCONFIG_EXPAND_OBSERVE), - argc, argv, - 2, NULL, NULL, 0); -} - -/* always returns either procedure or NULL */ -Scheme_Object *scheme_get_expand_observe() -{ - Scheme_Object *obs; - obs = scheme_get_param(scheme_current_config(), - MZCONFIG_EXPAND_OBSERVE); - if (SCHEME_PROCP(obs)) { - return obs; - } else { - return NULL; - } -} - -void scheme_init_expand_observe(Scheme_Env *env) -{ - Scheme_Env *newenv; - Scheme_Object *modname; - - modname = scheme_intern_symbol("#%expobs"); - newenv = scheme_primitive_module(modname, env); - - scheme_add_global_constant - ("current-expand-observe", - scheme_register_parameter(current_expand_observe, - "current-expand-observe", - MZCONFIG_EXPAND_OBSERVE), - newenv); - scheme_finish_primitive_module(newenv); -} - -/**********************************************************************/ -/* precise GC */ /**********************************************************************/ #ifdef MZ_PRECISE_GC @@ -7186,6 +9397,13 @@ START_XFORM_SKIP; static void register_traversers(void) { + GC_REG_TRAV(scheme_rename_table_type, mark_rename_table); + GC_REG_TRAV(scheme_rename_table_set_type, mark_rename_table_set); + GC_REG_TRAV(scheme_rt_srcloc, mark_srcloc); + GC_REG_TRAV(scheme_wrap_chunk_type, mark_wrapchunk); + GC_REG_TRAV(scheme_certifications_type, mark_cert); + GC_REG_TRAV(scheme_lexical_rib_type, lex_rib); + GC_REG_TRAV(scheme_free_id_info_type, mark_free_id_info); } END_XFORM_SKIP; diff --git a/src/racket/src/validate.c b/src/racket/src/validate.c new file mode 100644 index 0000000000..184197cd25 --- /dev/null +++ b/src/racket/src/validate.c @@ -0,0 +1,1563 @@ +/* + Racket + Copyright (c) 2004-2011 PLT Scheme Inc. + Copyright (c) 1995-2001 Matthew Flatt + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later version. + + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + Library General Public License for more details. + + You should have received a copy of the GNU Library General Public + License along with this library; if not, write to the Free + Software Foundation, Inc., 51 Franklin Street, Fifth Floor, + Boston, MA 02110-1301 USA. + + libscheme + Copyright (c) 1994 Brent Benson + All rights reserved. +*/ + +#include "schpriv.h" +#include "schrunst.h" +#include "schmach.h" + +/* Bytecode validation is an abstract interpretation on the stack, + where the abstract values are "not available", "value", "boxed + value", "syntax object", or "global array". */ + +/* FIXME: validation doesn't check CLOS_SINGLE_RESULT or + CLOS_PRESERVES_MARKS. (Maybe check them in the JIT pass?) */ + +#ifdef MZ_PRECISE_GC +static void register_traversers(void); +#endif + +void scheme_init_validate() +{ +#ifdef MZ_PRECISE_GC + register_traversers(); +#endif +} + +#define VALID_NOT 0 +#define VALID_UNINIT 1 +#define VALID_VAL 2 +#define VALID_BOX 3 +#define VALID_TOPLEVELS 4 +#define VALID_VAL_NOCLEAR 5 +#define VALID_BOX_NOCLEAR 6 +#define VALID_FLONUM 7 + +typedef struct Validate_Clearing { + MZTAG_IF_REQUIRED + int stackpos, stacksize; + int *stack; + int ncstackpos, ncstacksize; + int *ncstack; + int self_pos, self_count, self_start; +} Validate_Clearing; + +static struct Validate_Clearing *make_clearing_stack() +{ + Validate_Clearing *vc; + vc = MALLOC_ONE_RT(Validate_Clearing); + SET_REQUIRED_TAG(vc->type = scheme_rt_validate_clearing); + vc->self_pos = -1; + return vc; +} + +static void reset_clearing(struct Validate_Clearing *vc) +{ + vc->stackpos = 0; + vc->ncstackpos = 0; +} + +static void clearing_stack_push(struct Validate_Clearing *vc, int pos, int val) +{ + if (vc->stackpos + 2 > vc->stacksize) { + int *a, sz; + sz = (vc->stacksize ? 2 * vc->stacksize : 32); + a = (int *)scheme_malloc_atomic(sizeof(int) * sz); + memcpy(a, vc->stack, vc->stacksize * sizeof(int)); + vc->stacksize = sz; + vc->stack = a; + } + vc->stack[vc->stackpos] = pos; + vc->stack[vc->stackpos + 1] = val; + vc->stackpos += 2; +} + +static void noclear_stack_push(struct Validate_Clearing *vc, int pos) +{ + if (vc->ncstackpos + 1 > vc->ncstacksize) { + int *a, sz; + sz = (vc->ncstacksize ? 2 * vc->ncstacksize : 32); + a = (int *)scheme_malloc_atomic(sizeof(int) * sz); + memcpy(a, vc->ncstack, vc->ncstacksize * sizeof(int)); + vc->ncstacksize = sz; + vc->ncstack = a; + } + vc->ncstack[vc->ncstackpos] = pos; + vc->ncstackpos += 1; +} + +void scheme_validate_code(Mz_CPort *port, Scheme_Object *code, + int depth, + int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int code_vec) +{ + char *stack; + int delta; + struct Validate_Clearing *vc; + Validate_TLS tls; + + depth += ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); + + stack = scheme_malloc_atomic(depth); + memset(stack, VALID_NOT, depth); + + if (num_toplevels || num_stxes || num_lifts) { + stack[depth - 1] = VALID_TOPLEVELS; + } + + delta = depth - ((num_toplevels || num_stxes || num_lifts) ? 1 : 0); + + tls = MALLOC_N(mzshort*, num_lifts); + + vc = make_clearing_stack(); + + if (code_vec) { + int i, cnt; + cnt = SCHEME_VEC_SIZE(code); + for (i = 0; i < cnt; i++) { + reset_clearing(vc); + scheme_validate_expr(port, SCHEME_VEC_ELS(code)[i], + stack, tls, + depth, delta, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, + vc, 1, 0, NULL); + } + } else { + scheme_validate_expr(port, code, + stack, tls, + depth, delta, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, + vc, 1, 0, NULL); + } +} + +/*========================================================================*/ +/* other syntax */ +/*========================================================================*/ + +static void validate_toplevel(Scheme_Object *expr, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int delta, + int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int skip_refs_check) +{ + if (!SAME_TYPE(scheme_toplevel_type, SCHEME_TYPE(expr))) + scheme_ill_formed_code(port); + + scheme_validate_expr(port, expr, stack, tls, + depth, delta, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, skip_refs_check ? 1 : 0, 0, + make_clearing_stack(), 0, 0, NULL); +} + +static void define_values_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + int i, size; + Scheme_Object *val, *only_var; + + val = SCHEME_VEC_ELS(data)[0]; + size = SCHEME_VEC_SIZE(data); + + if (size == 2) + only_var = SCHEME_VEC_ELS(data)[1]; + else + only_var = NULL; + + for (i = 1; i < size; i++) { + validate_toplevel(SCHEME_VEC_ELS(data)[i], port, stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + 1); + } + + if (only_var) { + int pos; + pos = SCHEME_TOPLEVEL_POS(only_var); + if (pos >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + /* It's a lift. Check whether it needs to take reference arguments + and/or install reference info. */ + Scheme_Object *app_rator; + Scheme_Closure_Data *data = NULL; + int tp = pos - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); + mzshort *a, *new_a = NULL; + + /* Make sure that no one has tried to register information. */ + a = tls[tp]; + if (a && (a != (mzshort *)0x1) && (a[0] < 1)) + scheme_ill_formed_code(port); + + /* Convert rator to ref-arg info: */ + app_rator = val; + while (1) { + if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_closure_type)) { + data = SCHEME_COMPILED_CLOS_CODE(app_rator); + break; + } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_unclosed_procedure_type)) { + data = (Scheme_Closure_Data *)app_rator; + break; + } else if (SAME_TYPE(SCHEME_TYPE(app_rator), scheme_toplevel_type)) { + /* Record an indirection */ + data = NULL; + new_a = MALLOC_N_ATOMIC(mzshort, 2); + new_a[0] = 0; + new_a[1] = SCHEME_TOPLEVEL_POS(app_rator); + break; + } else { + /* Not a procedure */ + data = NULL; + new_a = (mzshort *)0x1; + break; + } + } + if (data) { + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + int sz; + sz = data->num_params; + a = MALLOC_N_ATOMIC(mzshort, (sz + 1)); + a[0] = -sz; + for (i = 0; i < sz; i++) { + int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); + if (data->closure_map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) + a[i + 1] = 1; + else + a[i + 1] = 0; + } + } else { + new_a = (mzshort *)0x1; + } + } + + /* Install info: */ + tls[tp] = new_a; + + /* Check old hopes against actual */ + if (a == (mzshort *)0x1) { + if (new_a != (mzshort *)0x1) + scheme_ill_formed_code(port); + } else if (a) { + int cnt = a[0], i; + + for (i = 0; i < cnt; i++) { + if (a[i + 1]) { + int is; + is = scheme_validate_rator_wants_box(val, i, + a[i + 1] == 2, + tls, num_toplevels, num_stxes, num_lifts, tl_use_map); + if ((is && (a[i + 1] == 1)) + || (!is && (a[i + 1] == 2))) + scheme_ill_formed_code(port); + } + } + } + } else + only_var = NULL; + } + + scheme_validate_expr(port, val, stack, tls, + depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, !!only_var, 0, vc, 0, 0, NULL); +} + +static void set_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + Scheme_Set_Bang *sb = (Scheme_Set_Bang *)data; + + scheme_validate_expr(port, sb->val, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + validate_toplevel(sb->var, port, stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + 0); +} + +static void ref_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + validate_toplevel(SCHEME_PTR1_VAL(data), port, stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + 0); + validate_toplevel(SCHEME_PTR2_VAL(data), port, stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + 0); +} + +static void apply_values_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + Scheme_Object *f, *e; + + f = SCHEME_PTR1_VAL(data); + e = SCHEME_PTR2_VAL(data); + + scheme_validate_expr(port, f, stack, tls, + depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + scheme_validate_expr(port, e, stack, tls, + depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); +} + +static void case_lambda_validate(Scheme_Object *data, Mz_CPort *port, char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + Scheme_Case_Lambda *seq = (Scheme_Case_Lambda *)data; + Scheme_Object *e; + int i; + + if (!SAME_TYPE(SCHEME_TYPE(data), scheme_case_lambda_sequence_type)) + scheme_ill_formed_code(port); + + for (i = 0; i < seq->count; i++) { + e = seq->array[i]; + if (!SAME_TYPE(SCHEME_TYPE(e), scheme_unclosed_procedure_type) + && !SAME_TYPE(SCHEME_TYPE(e), scheme_closure_type)) + scheme_ill_formed_code(port); + scheme_validate_expr(port, e, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + } +} + +static void validate_boxenv(int p, Mz_CPort *port, char *stack, int depth, int delta, int letlimit) +{ + if (p >= 0) + p += delta; + + if ((p < 0) || (p >= letlimit) || (stack[p] != VALID_VAL)) + scheme_ill_formed_code(port); + + stack[p] = VALID_BOX; +} + +static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + validate_boxenv(SCHEME_INT_VAL(SCHEME_PTR1_VAL(data)), port, stack, depth, delta, letlimit); + + scheme_validate_expr(port, SCHEME_PTR2_VAL(data), stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, result_ignored, vc, tailpos, 0, procs); +} + +static void begin0_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + Scheme_Sequence *seq = (Scheme_Sequence *)data; + int i; + + if (!SAME_TYPE(SCHEME_TYPE(seq), scheme_begin0_sequence_type) + && !SAME_TYPE(SCHEME_TYPE(seq), scheme_sequence_type)) + scheme_ill_formed_code(port); + + for (i = 0; i < seq->count; i++) { + scheme_validate_expr(port, seq->array[i], stack, tls, + depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, i > 0, vc, 0, 0, procs); + } +} + +static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int for_stx) +{ + Resolve_Prefix *rp; + Scheme_Object *name, *val, *base_stack_depth, *dummy; + int sdepth; + + if (!SCHEME_VECTORP(data) + || (SCHEME_VEC_SIZE(data) < 4)) + scheme_ill_formed_code(port); + + rp = (Resolve_Prefix *)SCHEME_VEC_ELS(data)[1]; + base_stack_depth = SCHEME_VEC_ELS(data)[2]; + sdepth = SCHEME_INT_VAL(base_stack_depth); + + if (!SAME_TYPE(rp->so.type, scheme_resolve_prefix_type) + || (sdepth < 0)) + scheme_ill_formed_code(port); + + dummy = SCHEME_VEC_ELS(data)[3]; + + if (!for_stx) { + int i, size; + size = SCHEME_VEC_SIZE(data); + for (i = 4; i < size; i++) { + name = SCHEME_VEC_ELS(data)[i]; + if (!SCHEME_SYMBOLP(name)) { + scheme_ill_formed_code(port); + } + } + } + + validate_toplevel(dummy, port, stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + 0); + + if (!for_stx) { + scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); + } else { + /* Make a fake `define-values' to check with respect to the exp-time stack */ + val = scheme_clone_vector(data, 3, 1); + SCHEME_VEC_ELS(val)[0] = SCHEME_VEC_ELS(data)[0]; + scheme_validate_code(port, val, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, 0); + } +} + +static void define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, 0); +} + +static void define_for_syntaxes_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + do_define_syntaxes_validate(data, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, 1); +} + +/*========================================================================*/ +/* expressions */ +/*========================================================================*/ + +static Scheme_Object *validate_k(void) +{ + Scheme_Thread *p = scheme_current_thread; + Mz_CPort *port = (Mz_CPort *)p->ku.k.p1; + Scheme_Object *expr = (Scheme_Object *)p->ku.k.p2; + char *stack = (char *)p->ku.k.p3; + int *args = (int *)(((void **)p->ku.k.p5)[0]); + Scheme_Object *app_rator = (Scheme_Object *)(((void **)p->ku.k.p5)[1]); + Validate_TLS tls = (Validate_TLS)(((void **)p->ku.k.p5)[2]); + Scheme_Hash_Tree *procs = (Scheme_Hash_Tree *)(((void **)p->ku.k.p5)[3]); + struct Validate_Clearing *vc = (struct Validate_Clearing *)p->ku.k.p4; + void *tl_use_map = (((void **)p->ku.k.p5)[4]); + + p->ku.k.p1 = NULL; + p->ku.k.p2 = NULL; + p->ku.k.p3 = NULL; + p->ku.k.p4 = NULL; + p->ku.k.p5 = NULL; + + scheme_validate_expr(port, expr, stack, tls, + args[0], args[1], args[2], + args[3], args[4], args[5], tl_use_map, + app_rator, args[6], args[7], vc, args[8], + args[9], procs); + + return scheme_true; +} + +/* FIXME: need to validate that a flonum is provided when a + procedure expects a flonum */ + +int scheme_validate_rator_wants_box(Scheme_Object *app_rator, int pos, + int hope, + Validate_TLS tls, + int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map) +{ + Scheme_Closure_Data *data = NULL; + Scheme_Type ty; + + while (1) { + ty = SCHEME_TYPE(app_rator); + if (SAME_TYPE(ty, scheme_closure_type)) { + data = SCHEME_COMPILED_CLOS_CODE(app_rator); + break; + } else if (SAME_TYPE(ty, scheme_unclosed_procedure_type)) { + data = (Scheme_Closure_Data *)app_rator; + break; + } else if (SAME_TYPE(ty, scheme_toplevel_type)) { + int p; + p = SCHEME_TOPLEVEL_POS(app_rator); + while (1) { + if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + /* It's a lift. Check that the lift is defined, and that it + doesn't want reference arguments. */ + mzshort *a; /* 0x1 => no ref args, + ptr with pos length => expected (0 => don't care, 1 => want not, 2 => want is), + ptr with neg length => actual + ptr with 0 => another top-level */ + int tp; + + tp = (p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0))); + if (tp >= num_lifts) + return 0; + + a = tls[tp]; + if (a == (mzshort *)0x1) { + return 0; + } else if (!a || (a[0] > 0)) { + /* The lift isn't ready. + Record what we expect to find when it is ready. */ + if (!a || (a[0] < (pos + 1))) { + mzshort *naya; + int sz; + if (a) + sz = a[0]; + else + sz = 3; + sz *= 2; + if (sz <= pos) + sz = pos + 1; + naya = scheme_malloc_atomic((sz + 1) * sizeof(mzshort)); + memset(naya, 0, (sz + 1) * sizeof(mzshort)); + if (a) + memcpy(naya, a, (a[0] + 1) * sizeof(mzshort)); + naya[0] = sz; + a = naya; + tls[tp] = a; + } + + if (!a[pos + 1]) { + a[pos + 1] = hope ? 2 : 1; + return hope; + } else if (a[pos + 1] == 2) + return 1; + else + return 0; + } else if (!a[0]) { + /* try again */ + p = a[1]; + } else { + return a[pos + 1]; + } + } else + return 0; + } + } else + return 0; + } + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + if (pos < data->num_params) { + int bit = ((mzshort)1 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); + if (data->closure_map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) + return 1; + } + } + + return 0; +} + +static int argument_to_arity_error(Scheme_Object *app_rator, int proc_with_refs_ok) +{ + /* Since `raise-arity-error' doesn't actually apply its argument, + it's ok to pass any procedure. In particular, the compiler generates + calls to converted procedures. */ + return ((proc_with_refs_ok == 2) + && SAME_OBJ(app_rator, scheme_raise_arity_error_proc)); +} + +void scheme_validate_closure(Mz_CPort *port, Scheme_Object *expr, + char *closure_stack, Validate_TLS tls, + int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + int self_pos_in_closure, Scheme_Hash_Tree *procs) +{ + Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; + int i, sz, cnt, base, base2; + char *new_stack; + struct Validate_Clearing *vc; + + if (data->max_let_depth < (data->num_params + data->closure_size)) + scheme_ill_formed_code(port); + + sz = data->max_let_depth; + new_stack = scheme_malloc_atomic(sz); + memset(new_stack, VALID_NOT, sz - data->num_params - data->closure_size); + + cnt = data->num_params; + base = sz - cnt; + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + base2 = data->closure_size; + for (i = 0; i < cnt; i++) { + new_stack[base + i] = closure_stack[base2 + i]; + } + } else { + for (i = 0; i < cnt; i++) { + new_stack[i + base] = VALID_VAL; + } + } + + cnt = data->closure_size; + base = base - cnt; + for (i = 0; i < cnt; i++) { + new_stack[i + base] = closure_stack[i]; + } + + vc = make_clearing_stack(); + if (self_pos_in_closure >= 0) { + vc->self_pos = base + self_pos_in_closure; + vc->self_count = data->closure_size; + vc->self_start = base; + } + + if (data->tl_map) { + if (tl_use_map) { + /* check that data->tl_use_map => tl_use_map */ + int *a, a_buf[2], len; + + if ((uintptr_t)tl_use_map & 0x1) { + len = 1; + a_buf[1] = (((uintptr_t)data->tl_map) >> 1) & 0x7FFFFFFF; + a = a_buf; + } else { + len = ((int *)tl_use_map)[0]; + a = (int *)tl_use_map; + } + + if (tl_use_map) { + if ((uintptr_t)data->tl_map & 0x1) { + int map = (((uintptr_t)data->tl_map) >> 1) & 0x7FFFFFFF; + if ((len < 1) || ((a[1] & map) != map)) + scheme_ill_formed_code(port); + } else { + int *b = ((int *)data->tl_map); + for (i = b[0]; i--; ) { + if ((len <= i) || ((a[i+1] & b[i+1]) != b[i+1])) + scheme_ill_formed_code(port); + } + } + } + } + tl_use_map = data->tl_map; + } + + scheme_validate_expr(port, data->code, new_stack, tls, sz, sz, base, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 1, 0, procs); +} + +static Scheme_Hash_Tree *as_nonempty_procs(Scheme_Hash_Tree *procs) +{ + if (!procs) + procs = scheme_make_hash_tree(0); + return procs; +} + +static void validate_unclosed_procedure(Mz_CPort *port, Scheme_Object *expr, + char *stack, Validate_TLS tls, + int depth, int delta, + int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + Scheme_Object *app_rator, int proc_with_refs_ok, + int self_pos, Scheme_Hash_Tree *procs) +{ + Scheme_Closure_Data *data = (Scheme_Closure_Data *)expr; + int i, cnt, q, p, sz, base, stack_delta, vld, self_pos_in_closure = -1, typed_arg = 0; + mzshort *map; + char *closure_stack; + Scheme_Object *proc; + Scheme_Hash_Tree *new_procs = NULL; + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + sz = data->closure_size + data->num_params; + } else { + sz = data->closure_size; + } + map = data->closure_map; + + if (sz) + closure_stack = scheme_malloc_atomic(sz); + else + closure_stack = NULL; + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + cnt = data->num_params; + base = sz - cnt; + for (i = 0; i < cnt; i++) { + int bit = ((mzshort)1 << ((2 * i) & (BITS_PER_MZSHORT - 1))); + if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & bit) { + vld = VALID_BOX; + typed_arg = 1; + } else if (map[data->closure_size + ((2 * i) / BITS_PER_MZSHORT)] & (bit << 1)) { + vld = VALID_FLONUM; + typed_arg = 1; + } else + vld = VALID_VAL; + closure_stack[i + base] = vld; + } + } else { + base = sz; + } + + cnt = data->closure_size; + base = base - cnt; + stack_delta = data->max_let_depth - sz; + + for (i = 0; i < cnt; i++) { + q = map[i]; + if (q == self_pos) + self_pos_in_closure = i; + p = q + delta; + if ((q < 0) || (p >= depth) || (stack[p] <= VALID_UNINIT)) + scheme_ill_formed_code(port); + vld = stack[p]; + if (vld == VALID_VAL_NOCLEAR) + vld = VALID_VAL; + else if (vld == VALID_BOX_NOCLEAR) + vld = VALID_BOX; + + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_TYPED_ARGS) { + int pos = data->num_params + i; + int bit = ((mzshort)2 << ((2 * pos) & (BITS_PER_MZSHORT - 1))); + if (map[data->closure_size + ((2 * pos) / BITS_PER_MZSHORT)] & bit) { + if (vld != VALID_FLONUM) + vld = VALID_NOT; + } else if (vld == VALID_FLONUM) + vld = VALID_NOT; + } else if (vld == VALID_FLONUM) + vld = VALID_NOT; + + closure_stack[i + base] = vld; + + if (procs) { + proc = scheme_hash_tree_get(procs, scheme_make_integer(p)); + if (proc) + new_procs = scheme_hash_tree_set(as_nonempty_procs(new_procs), + scheme_make_integer(i + base + stack_delta), + proc); + } + } + + if (typed_arg) { + if ((proc_with_refs_ok != 1) + && !argument_to_arity_error(app_rator, proc_with_refs_ok)) + scheme_ill_formed_code(port); + } + + if (SCHEME_RPAIRP(data->code)) { + /* Delay validation */ + Scheme_Object *vec; + vec = scheme_make_vector(9, NULL); + SCHEME_VEC_ELS(vec)[0] = SCHEME_CAR(data->code); + SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)closure_stack; + SCHEME_VEC_ELS(vec)[2] = (Scheme_Object *)tls; + SCHEME_VEC_ELS(vec)[3] = scheme_make_integer(num_toplevels); + SCHEME_VEC_ELS(vec)[4] = scheme_make_integer(num_stxes); + SCHEME_VEC_ELS(vec)[5] = scheme_make_integer(num_lifts); + SCHEME_VEC_ELS(vec)[6] = scheme_make_integer(self_pos_in_closure); + SCHEME_VEC_ELS(vec)[7] = new_procs ? (Scheme_Object *)new_procs : scheme_false; + SCHEME_VEC_ELS(vec)[8] = tl_use_map ? tl_use_map : scheme_false; + SCHEME_CAR(data->code) = vec; + } else + scheme_validate_closure(port, expr, closure_stack, tls, + num_toplevels, num_stxes, num_lifts, tl_use_map, + self_pos_in_closure, new_procs); +} + +static void check_self_call_valid(Scheme_Object *rator, Mz_CPort *port, struct Validate_Clearing *vc, + int delta, char *stack) +{ + if ((vc->self_pos >= 0) + && SAME_TYPE(SCHEME_TYPE(rator), scheme_local_type) + && !SCHEME_GET_LOCAL_FLAGS(rator) + && ((SCHEME_LOCAL_POS(rator) + delta) == vc->self_pos)) { + /* For a self call, the JIT needs the closure data to be intact. */ + int i, pos; + for (i = vc->self_count; i--; ) { + pos = i + vc->self_start; + if (stack[pos] <= VALID_UNINIT) + scheme_ill_formed_code(port); + } + } +} + +static void module_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ + Scheme_Module *m; + int i, cnt, let_depth; + Resolve_Prefix *rp; + Scheme_Object *e; + + m = (Scheme_Module *)data; + +# define SCHEME_MODNAMEP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_resolved_module_path_type) + if (!SCHEME_MODNAMEP(m->modname)) + scheme_ill_formed_code(port); + + scheme_validate_code(port, m->body, m->max_let_depth, + m->prefix->num_toplevels, m->prefix->num_stxes, m->prefix->num_lifts, + NULL, + 1); + + /* validate exp-time code */ + cnt = SCHEME_VEC_SIZE(m->et_body); + for (i = 0; i < cnt; i++) { + e = SCHEME_VEC_ELS(m->et_body)[i]; + + let_depth = SCHEME_INT_VAL(SCHEME_VEC_ELS(e)[2]); + rp = (Resolve_Prefix *)SCHEME_VEC_ELS(e)[3]; + e = SCHEME_VEC_ELS(e)[1]; + + scheme_validate_code(port, e, let_depth, + rp->num_toplevels, rp->num_stxes, rp->num_lifts, NULL, + 0); + } +} + +static void top_level_require_validate(Scheme_Object *data, Mz_CPort *port, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, + void *tl_use_map, int result_ignored, + struct Validate_Clearing *vc, int tailpos, + Scheme_Hash_Tree *procs) +{ +} + +static void no_flo(int need_flonum, Mz_CPort *port) +{ + if (need_flonum) scheme_ill_formed_code(port); +} + +static void check_flo(Scheme_Object *expr, int need_flonum, Mz_CPort *port) +{ + if (need_flonum) { + if (!scheme_expr_produces_flonum(expr)) + scheme_ill_formed_code(port); + } +} + +#define CAN_RESET_STACK_SLOT 0 +#if !CAN_RESET_STACK_SLOT +# define WHEN_CAN_RESET_STACK_SLOT(x) 0 +#else +# define WHEN_CAN_RESET_STACK_SLOT(x) (x) +#endif + +void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr, + char *stack, Validate_TLS tls, + int depth, int letlimit, int delta, + int num_toplevels, int num_stxes, int num_lifts, void *tl_use_map, + Scheme_Object *app_rator, int proc_with_refs_ok, + int result_ignored, + struct Validate_Clearing *vc, int tailpos, + int need_flonum, Scheme_Hash_Tree *procs) +{ + Scheme_Type type; + int did_one = 0, vc_merge = 0, vc_merge_start = 0; + +#ifdef DO_STACK_CHECK +# include "mzstkchk.h" + { + Scheme_Thread *p = scheme_current_thread; + void **pr; + int *args; + + args = MALLOC_N_ATOMIC(int, 10); + + p->ku.k.p1 = (void *)port; + p->ku.k.p2 = (void *)expr; + p->ku.k.p3 = (void *)stack; + p->ku.k.p4 = (void *)vc; + + args[0] = depth; + args[1] = letlimit; + args[2] = delta; + args[3] = num_toplevels; + args[4] = num_stxes; + args[5] = num_lifts; + args[6] = proc_with_refs_ok; + args[7] = result_ignored; + args[8] = tailpos; + args[9] = need_flonum; + + pr = MALLOC_N(void*, 5); + pr[0] = (void *)args; + pr[1] = (void *)app_rator; + pr[2] = (void *)tls; + pr[3] = (void *)procs; + pr[4] = tl_use_map; + + p->ku.k.p5 = (void *)pr; + + (void)scheme_handle_stack_overflow(validate_k); + + return; + } +#endif + + top: + if (did_one) { + if (app_rator) { + if (scheme_validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, + tls, num_toplevels, num_stxes, num_lifts, + tl_use_map)) + scheme_ill_formed_code(port); + app_rator = NULL; + } + proc_with_refs_ok = 0; + } else + did_one = 1; + + type = SCHEME_TYPE(expr); + + switch (type) { + case scheme_toplevel_type: + { + int c = SCHEME_TOPLEVEL_DEPTH(expr); + int d = c + delta; + int p = SCHEME_TOPLEVEL_POS(expr); + + no_flo(need_flonum, port); + + if ((c < 0) || (p < 0) || (d >= depth) + || (stack[d] != VALID_TOPLEVELS) + || (p >= (num_toplevels + num_lifts + num_stxes + (num_stxes ? 1 : 0))) + || ((p >= num_toplevels) && (p < num_toplevels + num_stxes + (num_stxes ? 1 : 0)))) + scheme_ill_formed_code(port); + + if (tl_use_map) { + int p2 = ((p < num_toplevels) + ? p + : (num_stxes ? (p - num_stxes - 1) : p)); + if ((uintptr_t)tl_use_map & 0x1) { + if (p2 > 31) + scheme_ill_formed_code(port); + if (!((uintptr_t)tl_use_map & (1 << (p2 + 1)))) + scheme_ill_formed_code(port); + } else { + if (p2 >= (*(int *)tl_use_map * 32)) + scheme_ill_formed_code(port); + if (!(((int *)tl_use_map)[1 + (p2 / 32)] & (1 << (p2 & 31)))) + scheme_ill_formed_code(port); + } + } + + if ((proc_with_refs_ok != 1) + && !argument_to_arity_error(app_rator, proc_with_refs_ok)) { + if (p >= (num_toplevels + num_stxes + (num_stxes ? 1 : 0))) { + /* It's a lift. Check that the lift is defined, and that it + doesn't want reference arguments. */ + int tp; + mzshort *a; + tp = p - (num_toplevels + num_stxes + (num_stxes ? 1 : 0)); + a = tls[tp]; + if (a) { + if (a == (mzshort *)0x1) { + /* Ok */ + } else if (a[0] > 0) { + int i, cnt; + cnt = a[0]; + for (i = 0; i < cnt; i++) { + if (a[i] == 2) + scheme_ill_formed_code(port); + } + tls[tp] = (mzshort *)0x1; + } else { + /* a[0] is either 0 (top-level ref; shouldn't happen) or < 0 (wants some ref args) */ + scheme_ill_formed_code(port); + } + } else { + tls[tp] = (mzshort *)0x1; /* means "no ref args anywhere" */ + } + } + } + } + break; + case scheme_local_type: + { + int q = SCHEME_LOCAL_POS(expr); + int p = q + delta; + + if ((q < 0) || (p >= depth)) + scheme_ill_formed_code(port); + + if (SCHEME_GET_LOCAL_FLAGS(expr) != SCHEME_LOCAL_FLONUM) + no_flo(need_flonum, port); + + if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_FLONUM) { + if (stack[p] != VALID_FLONUM) + scheme_ill_formed_code(port); + } else if ((stack[p] != VALID_VAL) && (stack[p] != VALID_VAL_NOCLEAR)) { + if (result_ignored && ((stack[p] == VALID_BOX) + || (stack[p] == VALID_BOX_NOCLEAR) + || (stack[p] == VALID_FLONUM))) { + /* ok to look up and ignore box or flonum */ + } else if ((proc_with_refs_ok >= 2) + && ((stack[p] == VALID_BOX) || (stack[p] == VALID_BOX_NOCLEAR)) + && scheme_validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 1, + tls, num_toplevels, num_stxes, num_lifts, + tl_use_map)) { + /* It's ok - the function wants us to pass it a box, and + we did. */ + app_rator = NULL; + } else + scheme_ill_formed_code(port); + } + + if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_CLEAR_ON_READ) { + if ((stack[p] == VALID_VAL_NOCLEAR) || (stack[p] == VALID_BOX_NOCLEAR)) + scheme_ill_formed_code(port); + if (p >= letlimit) + clearing_stack_push(vc, p, stack[p]); + stack[p] = VALID_NOT; + } else if (!(SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_OTHER_CLEARS)) { + if (stack[p] == VALID_BOX) { + if (p >= letlimit) + noclear_stack_push(vc, p); + stack[p] = VALID_BOX_NOCLEAR; + } else if (stack[p] == VALID_VAL) { + if (p >= letlimit) + noclear_stack_push(vc, p); + stack[p] = VALID_VAL_NOCLEAR; + } + } + + if (procs && !proc_with_refs_ok && !result_ignored) { + if (scheme_hash_tree_get(procs, scheme_make_integer(p))) + scheme_ill_formed_code(port); + } + } + break; + case scheme_local_unbox_type: + { + int q = SCHEME_LOCAL_POS(expr); + int p = q + delta; + + no_flo(need_flonum, port); + + if ((q < 0) || (p >= depth) || ((stack[p] != VALID_BOX) + && (stack[p] != VALID_BOX_NOCLEAR))) + scheme_ill_formed_code(port); + + if (SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_CLEAR_ON_READ) { + if (stack[p] == VALID_BOX_NOCLEAR) + scheme_ill_formed_code(port); + if (p >= letlimit) + clearing_stack_push(vc, p, stack[p]); + stack[p] = VALID_NOT; + } else if (!(SCHEME_GET_LOCAL_FLAGS(expr) == SCHEME_LOCAL_OTHER_CLEARS)) { + if (stack[p] == VALID_BOX) { + if (p >= letlimit) + noclear_stack_push(vc, p); + stack[p] = VALID_BOX_NOCLEAR; + } + } + } + break; + case scheme_application_type: + { + Scheme_App_Rec *app = (Scheme_App_Rec *)expr; + int i, n; + + check_flo(expr, need_flonum, port); + + n = app->num_args + 1; + + delta -= (n - 1); + if (delta < 0) + scheme_ill_formed_code(port); + memset(stack + delta, VALID_NOT, n - 1); + + for (i = 0; i < n; i++) { + scheme_validate_expr(port, app->args[i], stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + i ? app->args[0] : NULL, i + 1, 0, vc, 0, 0, procs); + } + + if (tailpos) + check_self_call_valid(app->args[0], port, vc, delta, stack); + } + break; + case scheme_application2_type: + { + Scheme_App2_Rec *app = (Scheme_App2_Rec *)expr; + + check_flo(expr, need_flonum, port); + + delta -= 1; + if (delta < 0) + scheme_ill_formed_code(port); + stack[delta] = VALID_NOT; + + scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 1, 0, vc, 0, 0, procs); + scheme_validate_expr(port, app->rand, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + app->rator, 2, 0, vc, 0, 0, procs); + + if (tailpos) + check_self_call_valid(app->rator, port, vc, delta, stack); + } + break; + case scheme_application3_type: + { + Scheme_App3_Rec *app = (Scheme_App3_Rec *)expr; + + check_flo(expr, need_flonum, port); + + delta -= 2; + if (delta < 0) + scheme_ill_formed_code(port); + stack[delta] = VALID_NOT; + stack[delta+1] = VALID_NOT; + + scheme_validate_expr(port, app->rator, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 1, 0, vc, 0, 0, procs); + scheme_validate_expr(port, app->rand1, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + app->rator, 2, 0, vc, 0, 0, procs); + scheme_validate_expr(port, app->rand2, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + app->rator, 3, 0, vc, 0, 0, procs); + + if (tailpos) + check_self_call_valid(app->rator, port, vc, delta, stack); + } + break; + case scheme_sequence_type: + case scheme_splice_sequence_type: + { + Scheme_Sequence *seq = (Scheme_Sequence *)expr; + int cnt; + int i; + + no_flo(need_flonum, port); + + cnt = seq->count; + + for (i = 0; i < cnt - 1; i++) { + scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 1, vc, 0, 0, procs); + } + + expr = seq->array[cnt - 1]; + goto top; + } + break; + case scheme_branch_type: + { + Scheme_Branch_Rec *b; + int vc_pos, vc_ncpos; + + no_flo(need_flonum, port); + + b = (Scheme_Branch_Rec *)expr; + scheme_validate_expr(port, b->test, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + /* This is where letlimit is useful. It prevents let-assignment in the + "then" branch that could permit bad code in the "else" branch (or the + same thing with either branch affecting later code in a sequence). */ + letlimit = delta; + vc_pos = vc->stackpos; + vc_ncpos = vc->ncstackpos; + scheme_validate_expr(port, b->tbranch, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, result_ignored, vc, tailpos, 0, procs); + + /* Rewind clears and noclears, but also save the clears, + so that the branches' effects can be merged. */ + { + int i, j; + + if (!vc_merge) { + vc_merge = 1; + vc_merge_start = vc_pos; + } + + for (i = vc->stackpos - 2; i >= vc_pos; i -= 2) { + stack[vc->stack[i]] = vc->stack[i + 1]; + } + + for (i = vc->ncstackpos - 1; i >= vc_ncpos; i--) { + j = vc->ncstack[i]; + if (stack[j] == VALID_VAL_NOCLEAR) + stack[j] = VALID_VAL; + else if (stack[j] == VALID_BOX_NOCLEAR) + stack[j] = VALID_BOX; + } + vc->ncstackpos = vc_ncpos; + } + + expr = b->fbranch; + goto top; + } + break; + case scheme_with_cont_mark_type: + { + Scheme_With_Continuation_Mark *wcm = (Scheme_With_Continuation_Mark *)expr; + + no_flo(need_flonum, port); + + scheme_validate_expr(port, wcm->key, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + scheme_validate_expr(port, wcm->val, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + expr = wcm->body; + goto top; + } + break; + case scheme_quote_syntax_type: + { + Scheme_Quote_Syntax *qs = (Scheme_Quote_Syntax *)expr; + int c = qs->depth; + int i = qs->position; + int p = qs->midpoint; + int d = c + delta; + + no_flo(need_flonum, port); + + if ((c < 0) || (p < 0) || (d >= depth) + || (stack[d] != VALID_TOPLEVELS) + || (p != num_toplevels) + || (i >= num_stxes)) + scheme_ill_formed_code(port); + } + break; + case scheme_unclosed_procedure_type: + { + no_flo(need_flonum, port); + validate_unclosed_procedure(port, expr, stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + app_rator, proc_with_refs_ok, -1, procs); + } + break; + case scheme_let_value_type: + { + Scheme_Let_Value *lv = (Scheme_Let_Value *)expr; + int q, p, c, i; + + scheme_validate_expr(port, lv->value, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + /* memset(stack, VALID_NOT, delta); <-- seems unnecessary (and slow) */ + + c = lv->count; + q = lv->position; + p = q + delta; + + for (i = 0; i < c; i++, p++) { + if ((q < 0) + || (SCHEME_LET_AUTOBOX(lv) && ((p >= depth) + || ((stack[p] != VALID_BOX) + && (stack[p] != VALID_BOX_NOCLEAR)))) + || (!SCHEME_LET_AUTOBOX(lv) && ((p >= letlimit) + || !(WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL) + || WHEN_CAN_RESET_STACK_SLOT(stack[p] == VALID_VAL_NOCLEAR) + || (stack[p] == VALID_UNINIT))))) + scheme_ill_formed_code(port); + + if (!SCHEME_LET_AUTOBOX(lv)) { + if (stack[p] != VALID_VAL_NOCLEAR) + stack[p] = VALID_VAL; + } + } + + expr = lv->body; + goto top; + } + break; + case scheme_let_void_type: + { + Scheme_Let_Void *lv = (Scheme_Let_Void *)expr; + int c, i; + + c = lv->count; + + if ((c < 0) || (c > delta)) + scheme_ill_formed_code(port); + + if (SCHEME_LET_AUTOBOX(lv)) { + for (i = 0; i < c; i++) { + stack[--delta] = VALID_BOX; + } + } else { + delta -= c; + memset(stack + delta, VALID_UNINIT, c); + } + + expr = lv->body; + goto top; + } + break; + case scheme_letrec_type: + { + Scheme_Letrec *l = (Scheme_Letrec *)expr; + int i, c; + + c = l->count; + + if ((c < 0) || (c + delta > depth)) + scheme_ill_formed_code(port); + + for (i = 0; i < c; i++) { + if (!SAME_TYPE(SCHEME_TYPE(l->procs[i]), scheme_unclosed_procedure_type)) + scheme_ill_formed_code(port); + } + + for (i = 0; i < c; i++) { +#if !CAN_RESET_STACK_SLOT + if (stack[delta + i] != VALID_UNINIT) + scheme_ill_formed_code(port); +#endif + stack[delta + i] = VALID_VAL; + if (SCHEME_CLOSURE_DATA_FLAGS(((Scheme_Closure_Data *)l->procs[i])) & CLOS_HAS_TYPED_ARGS) { + procs = scheme_hash_tree_set(as_nonempty_procs(procs), + scheme_make_integer(delta + i), + l->procs[i]); + } + } + + for (i = 0; i < c; i++) { + validate_unclosed_procedure(port, l->procs[i], stack, tls, depth, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 1, i, procs); + } + + expr = l->body; + goto top; + } + break; + case scheme_let_one_type: + { + Scheme_Let_One *lo = (Scheme_Let_One *)expr; + + --delta; + if (delta < 0) + scheme_ill_formed_code(port); + stack[delta] = VALID_UNINIT; + + scheme_validate_expr(port, lo->value, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM, procs); + +#if !CAN_RESET_STACK_SLOT + if (stack[delta] != VALID_UNINIT) + scheme_ill_formed_code(port); +#endif + + if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_UNUSED) { + stack[delta] = VALID_NOT; + } else if (SCHEME_LET_EVAL_TYPE(lo) & LET_ONE_FLONUM) { + stack[delta] = VALID_FLONUM; + /* FIXME: need to check that lo->value produces a flonum */ + } else + stack[delta] = VALID_VAL; + + expr = lo->body; + goto top; + } + break; + + case scheme_define_values_type: + no_flo(need_flonum, port); + define_values_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_define_syntaxes_type: + no_flo(need_flonum, port); + define_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_define_for_syntax_type: + no_flo(need_flonum, port); + define_for_syntaxes_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_set_bang_type: + no_flo(need_flonum, port); + set_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_boxenv_type: + no_flo(need_flonum, port); + bangboxenv_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_begin0_sequence_type: + no_flo(need_flonum, port); + begin0_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_require_form_type: + no_flo(need_flonum, port); + top_level_require_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_varref_form_type: + no_flo(need_flonum, port); + ref_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_apply_values_type: + no_flo(need_flonum, port); + apply_values_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_case_lambda_sequence_type: + no_flo(need_flonum, port); + case_lambda_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + case scheme_module_type: + no_flo(need_flonum, port); + module_validate(expr, port, stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + result_ignored, vc, tailpos, procs); + break; + default: + /* All values are definitely ok, except pre-closed closures. + Such a closure can refer back to itself, so we use a flag + to track cycles. Also check need_flonum. */ + if (SAME_TYPE(type, scheme_closure_type)) { + Scheme_Closure_Data *data; + no_flo(need_flonum, port); + expr = (Scheme_Object *)SCHEME_COMPILED_CLOS_CODE(expr); + data = (Scheme_Closure_Data *)expr; + if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_VALIDATED) { + /* Done with this one. */ + } else { + SCHEME_CLOSURE_DATA_FLAGS(data) |= CLOS_VALIDATED; + did_one = 0; + goto top; + } + } else if (SAME_TYPE(type, scheme_case_closure_type)) { + Scheme_Case_Lambda *seq; + int i; + seq = (Scheme_Case_Lambda *)expr; + for (i = 0; i < seq->count; i++) { + scheme_validate_expr(port, seq->array[i], stack, tls, depth, letlimit, delta, + num_toplevels, num_stxes, num_lifts, tl_use_map, + NULL, 0, 0, vc, 0, 0, procs); + } + } else if (need_flonum) { + if (!SCHEME_FLOATP(expr)) + no_flo(need_flonum, port); + } + break; + } + + if (app_rator) + if (scheme_validate_rator_wants_box(app_rator, proc_with_refs_ok - 2, 0, + tls, num_toplevels, num_stxes, num_lifts, tl_use_map)) + scheme_ill_formed_code(port); + + if (vc_merge) { + /* Re-clear to merge effects from branches */ + int i, p; + for (i = vc_merge_start; i < vc->stackpos; i += 2) { + p = vc->stack[i]; + stack[p] = VALID_NOT; + } + } +} + +/*========================================================================*/ +/* precise GC traversers */ +/*========================================================================*/ + +#ifdef MZ_PRECISE_GC + +START_XFORM_SKIP; + +#define MARKS_FOR_VALIDATE_C +#include "mzmark.c" + +static void register_traversers(void) +{ + GC_REG_TRAV(scheme_rt_validate_clearing, mark_validate_clearing); +} + +END_XFORM_SKIP; + +#endif diff --git a/src/worksp/gc2/make.rkt b/src/worksp/gc2/make.rkt index b50d6371c6..409b7c430f 100644 --- a/src/worksp/gc2/make.rkt +++ b/src/worksp/gc2/make.rkt @@ -32,6 +32,8 @@ "bool" "builtin" "char" + "compenv" + "compile" "complex" "dynext" "env" @@ -47,9 +49,11 @@ "jitcall" "jitcommon" "jitinline" + "jitprep" "jitstack" "jitstate" "list" + "marshal" "module" "mzrt" "network" @@ -57,22 +61,25 @@ "number" "numcomp" "numstr" - "places" + "optimize" + "place" "port" "portfun" "print" "rational" "read" "regexp" + "resolve" "sema" "setjmpup" + "sfs" "string" "struct" "symbol" "syntax" - "stxobj" "thread" "type" + "validate" "vector")) (define common-cpp-defs " /D _CRT_SECURE_NO_DEPRECATE /D _USE_DECLSPECS_FOR_SAL=0 /D _USE_ATTRIBUTES_FOR_SAL=0 ") diff --git a/src/worksp/libracket/libracket.vcproj b/src/worksp/libracket/libracket.vcproj index 9fa05df93d..2180bd1eb2 100644 --- a/src/worksp/libracket/libracket.vcproj +++ b/src/worksp/libracket/libracket.vcproj @@ -561,6 +561,14 @@ RelativePath="..\..\Racket\Src\Char.c" > + + + + @@ -629,6 +637,10 @@ RelativePath="..\..\Racket\Src\jitinline.c" > + + @@ -645,6 +657,10 @@ RelativePath="..\..\Racket\Src\module.c" > + + @@ -674,7 +690,11 @@ > + + + + @@ -713,6 +737,10 @@ RelativePath="..\..\Racket\Src\Setjmpup.c" > + + @@ -721,10 +749,6 @@ RelativePath="..\..\Racket\Src\Struct.c" > - - @@ -741,6 +765,10 @@ RelativePath="..\..\Racket\Src\Type.c" > + + diff --git a/src/worksp10/libracket/libracket.vcxproj b/src/worksp10/libracket/libracket.vcxproj index f49a20809b..9654f1b7f4 100644 --- a/src/worksp10/libracket/libracket.vcxproj +++ b/src/worksp10/libracket/libracket.vcxproj @@ -187,6 +187,8 @@ + + @@ -204,9 +206,11 @@ + + @@ -215,23 +219,26 @@ - + + + + - +