From 2d63f03442cacf6991e0d2260f3f3fde29e18279 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 1 May 2017 20:08:59 -0600 Subject: [PATCH 1/8] support Windows build on Bash/WSL original commit: 7e4782db08210cbacd1bbe46b3a5e166d8dbe20f --- BUILDING | 13 ++++++++----- LOG | 3 +++ c/Mf-a6nt | 20 ++------------------ c/Mf-i3nt | 17 ++--------------- c/Mf-ta6nt | 20 ++------------------ c/Mf-ti3nt | 17 ++--------------- c/vs.bat | 39 +++++++++++++++++++++++++++++++++++++++ configure | 10 +++++++++- mats/Mf-a6nt | 4 ++-- mats/Mf-base | 10 +++++++++- mats/Mf-i3nt | 4 ++-- mats/Mf-ta6nt | 4 ++-- mats/Mf-ti3nt | 4 ++-- mats/vs.bat | 3 +++ s/Mf-base | 11 +++++++++-- workarea | 11 +++++++++++ 16 files changed, 107 insertions(+), 83 deletions(-) create mode 100644 c/vs.bat create mode 100644 mats/vs.bat diff --git a/BUILDING b/BUILDING index a3b411fd6e..59f9f18265 100644 --- a/BUILDING +++ b/BUILDING @@ -167,15 +167,18 @@ The make file supports several targets: WINDOWS -Building Chez Scheme under Windows with Cygwin follows the -instructions above except that make install is not supported: +Building Chez Scheme under Windows with Cygwin or Bash/WSL follows the +instructions above, except that 'make install' is not supported, and +the 'OS' environment variable must be set to 'Windows_NT' on Bash/WSL +(to indicate a build for Windows, as opposed to a build for Linux on +Windows): -./configure -make +env OS=Windows_NT ./configure +env OS=Windows_NT make Prerequisites: -* Cygwin with bash, grep, make, sed, etc. +* Cygwin or Bash/WSL with bash, grep, make, sed, etc. * Microsoft Visual Studio 2015 * WiX Toolset (for making an install) diff --git a/LOG b/LOG index 756badf8f3..1bdb8c5b54 100644 --- a/LOG +++ b/LOG @@ -450,3 +450,6 @@ Also add a simplification for for-each with empty lists with optimization level 2. cp0.ss, 4.ms, primdata.ss +- support Windows build on Bash/WSL + BUILDING, configure, workarea, c/vs.bat (new), mats/vs.bat (new), + c/Mf-*nt, mats/Mf-*, s/Mf-base diff --git a/c/Mf-a6nt b/c/Mf-a6nt index d9190b2a91..8b51ff88d9 100644 --- a/c/Mf-a6nt +++ b/c/Mf-a6nt @@ -25,27 +25,11 @@ mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* include Mf-base ${Scheme}: make.bat - ./make.bat + cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe -vs.bat: - echo '@echo off' > $@ - echo 'if "%VS140COMNTOOLS%" neq "" goto :VS' >> $@ - echo 'echo Visual Studio 2015 must be installed.' >> $@ - echo 'exit 1' >> $@ - echo ':VS' >> $@ - echo 'set INCLUDE=' >> $@ - echo 'set LIB=' >> $@ - echo 'set LIBPATH=' >> $@ - echo 'set MACHINETYPE=amd64' >> $@ - echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\x86_amd64\vcvarsx86_amd64.bat" set MACHINETYPE=x86_amd64' >> $@ - echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\amd64\vcvars64.bat" set MACHINETYPE=amd64' >> $@ - echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" %MACHINETYPE%' >> $@ - echo '%*' >> $@ - chmod +x $@ - make.bat: vs.bat echo '@echo off' > $@ echo 'set MAKEFLAGS=' >> $@ - echo 'call vs.bat nmake /f Makefile.$m /nologo %*' >> $@ + echo 'vs.bat x86_amd64 amd64 && nmake /f Makefile.$m /nologo %*' >> $@ chmod +x $@ diff --git a/c/Mf-i3nt b/c/Mf-i3nt index b41c755208..855721aa9d 100644 --- a/c/Mf-i3nt +++ b/c/Mf-i3nt @@ -25,24 +25,11 @@ mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* include Mf-base ${Scheme}: make.bat - ./make.bat + cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe -vs.bat: - echo '@echo off' > $@ - echo 'if "%VS140COMNTOOLS%" neq "" goto :VS' >> $@ - echo 'echo Visual Studio 2015 must be installed.' >> $@ - echo 'exit 1' >> $@ - echo ':VS' >> $@ - echo 'set INCLUDE=' >> $@ - echo 'set LIB=' >> $@ - echo 'set LIBPATH=' >> $@ - echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" x86' >> $@ - echo '%*' >> $@ - chmod +x $@ - make.bat: vs.bat echo '@echo off' > $@ echo 'set MAKEFLAGS=' >> $@ - echo 'call vs.bat nmake /f Makefile.$m /nologo %*' >> $@ + echo 'vs.bat x86 && nmake /f Makefile.$m /nologo %*' >> $@ chmod +x $@ diff --git a/c/Mf-ta6nt b/c/Mf-ta6nt index 0129efd815..35638cb319 100644 --- a/c/Mf-ta6nt +++ b/c/Mf-ta6nt @@ -25,27 +25,11 @@ mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* include Mf-base ${Scheme}: make.bat - ./make.bat + cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe -vs.bat: - echo '@echo off' > $@ - echo 'if "%VS140COMNTOOLS%" neq "" goto :VS' >> $@ - echo 'echo Visual Studio 2015 must be installed.' >> $@ - echo 'exit 1' >> $@ - echo ':VS' >> $@ - echo 'set INCLUDE=' >> $@ - echo 'set LIB=' >> $@ - echo 'set LIBPATH=' >> $@ - echo 'set MACHINETYPE=amd64' >> $@ - echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\x86_amd64\vcvarsx86_amd64.bat" set MACHINETYPE=x86_amd64' >> $@ - echo 'if exist "%VS140COMNTOOLS%..\..\VC\bin\amd64\vcvars64.bat" set MACHINETYPE=amd64' >> $@ - echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" %MACHINETYPE%' >> $@ - echo '%*' >> $@ - chmod +x $@ - make.bat: vs.bat echo '@echo off' > $@ echo 'set MAKEFLAGS=' >> $@ - echo 'call vs.bat nmake /f Makefile.$m /nologo %*' >> $@ + echo 'vs.bat x86_amd64 amd64 && nmake /f Makefile.$m /nologo %*' >> $@ chmod +x $@ diff --git a/c/Mf-ti3nt b/c/Mf-ti3nt index b2ac822097..5503422757 100644 --- a/c/Mf-ti3nt +++ b/c/Mf-ti3nt @@ -25,24 +25,11 @@ mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* include Mf-base ${Scheme}: make.bat - ./make.bat + cmd.exe /c make.bat cp ../bin/$m/scheme.exe ../bin/$m/petite.exe -vs.bat: - echo '@echo off' > $@ - echo 'if "%VS140COMNTOOLS%" neq "" goto :VS' >> $@ - echo 'echo Visual Studio 2015 must be installed.' >> $@ - echo 'exit 1' >> $@ - echo ':VS' >> $@ - echo 'set INCLUDE=' >> $@ - echo 'set LIB=' >> $@ - echo 'set LIBPATH=' >> $@ - echo 'call "%VS140COMNTOOLS%..\..\VC\vcvarsall.bat" x86' >> $@ - echo '%*' >> $@ - chmod +x $@ - make.bat: vs.bat echo '@echo off' > $@ echo 'set MAKEFLAGS=' >> $@ - echo 'call vs.bat nmake /f Makefile.$m /nologo %*' >> $@ + echo 'vs.bat x86 && nmake /f Makefile.$m /nologo %*' >> $@ chmod +x $@ diff --git a/c/vs.bat b/c/vs.bat new file mode 100644 index 0000000000..103db58cd6 --- /dev/null +++ b/c/vs.bat @@ -0,0 +1,39 @@ +@echo off + +:: Set up Visual Studio command line environment variables given a +:: sequence of machine types to try ("x86", "x86_amd64", and "amd64"). + +:: Note: VS 11.0 (2012) and earlier won't work, because they +:: don't support C99 mid-block declarations. Also, there's no +:: such thing as VS 13.0. + +:: Clear environment variables that we might otherwise inherit +set INCLUDE= +set LIB= +set LIBPATH= + +:: Find visual studio +set VCDIR=%VS140COMNTOOLS%\..\..\vc +if not exist "%VCDIR%\vcvarsall.bat" set VCDIR=%VS120COMNTOOLS%\..\..\vc + +:: Loop to find a requested machine type +if exist "%VCDIR%\vcvarsall.bat" goto :VCDIR +echo Could not find Visual Studio installed. +exit 1 + +:VCDIR + +set MACHINETYPE=%1 +if "%MACHINETYPE%" neq "" goto :MACHINE +echo Could not find working machine type. +exit 1 + +:MACHINE +if "%MACHINETYPE%" == "x86" goto :VS +if exist "%VCDIR%\bin\%MACHINETYPE%\vcvars%MACHINETYPE%.bat" goto :VS +shift +goto :VCDIR + +:: Set environment variables +:VS +"%VCDIR%\vcvarsall.bat" %MACHINETYPE% diff --git a/configure b/configure index 577b3b4003..b048237251 100755 --- a/configure +++ b/configure @@ -41,7 +41,15 @@ installscriptname="scheme-script" : ${CFLAGS:=""} : ${LDFLAGS:=""} -case `uname` in +# On WSL, set OS to "Windows_NT" to create a Windows +# build instead of a Linux (on Windows) build: +if [ "$OS" = "Windows_NT" ] ; then + CONFIG_UNAME="CYGWIN_NT-" +else + CONFIG_UNAME=`uname` +fi + +case "${CONFIG_UNAME}" in Linux) if uname -a | egrep 'i386|i686|amd64|athlon|x86_64' > /dev/null 2>&1 ; then m32=i3le diff --git a/mats/Mf-a6nt b/mats/Mf-a6nt index 333892e41e..6fec7b426e 100644 --- a/mats/Mf-a6nt +++ b/mats/Mf-a6nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - ../c/vs.bat cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc) + cmd.exe /c "vs.bat x86_amd64 amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" cat_flush: cat_flush.c - ../c/vs.bat cl /DWIN32 /DX86_64 /MD /nologo $< + cmd.exe /c "vs.bat x86_amd64 amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<" diff --git a/mats/Mf-base b/mats/Mf-base index f4486d669c..3ddca00b24 100644 --- a/mats/Mf-base +++ b/mats/Mf-base @@ -39,9 +39,17 @@ ifeq (${OS},Windows_NT) else dirsep = : endif + +# Explicit ".exe" needed for WSL +ifeq ($(OS),Windows_NT) + ExeSuffix = .exe +else + ExeSuffix = +endif + # Scheme is the scheme executable to test, and SCHEMEHEAPDIRS tells # it where to find its boot files -Scheme = ../bin/$m/scheme +Scheme = ../bin/$m/scheme${ExeSuffix} export SCHEMEHEAPDIRS=.${dirsep}../boot/%m # Include is the directory holding scheme.h. diff --git a/mats/Mf-i3nt b/mats/Mf-i3nt index 1c49b8a855..e76e0d35c0 100644 --- a/mats/Mf-i3nt +++ b/mats/Mf-i3nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - ../c/vs.bat cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc) + cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" cat_flush: cat_flush.c - ../c/vs.bat cl /DWIN32 /MD /nologo $< + cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<" diff --git a/mats/Mf-ta6nt b/mats/Mf-ta6nt index 3a6333045d..51f63e744d 100644 --- a/mats/Mf-ta6nt +++ b/mats/Mf-ta6nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - ../c/vs.bat cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc) + cmd.exe /c "vs.bat x86_amd64 amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" cat_flush: cat_flush.c - ../c/vs.bat cl /DWIN32 /DX86_64 /MD /nologo $< + cmd.exe /c "vs.bat x86_amd64 amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<" diff --git a/mats/Mf-ti3nt b/mats/Mf-ti3nt index 85c1fdedbc..b6939e6d08 100644 --- a/mats/Mf-ti3nt +++ b/mats/Mf-ti3nt @@ -22,7 +22,7 @@ mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj for include Mf-base foreign1.so: $(fsrc) - ../c/vs.bat cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc) + cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv941.lib $(fsrc)" cat_flush: cat_flush.c - ../c/vs.bat cl /DWIN32 /MD /nologo $< + cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<" diff --git a/mats/vs.bat b/mats/vs.bat new file mode 100644 index 0000000000..85e733ed24 --- /dev/null +++ b/mats/vs.bat @@ -0,0 +1,3 @@ +:: Redirect to "..\c\vs.bat" without having to use +:: backslashes in the makefile +..\c\vs.bat %* diff --git a/s/Mf-base b/s/Mf-base index 9805933c4d..200d444394 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -67,10 +67,17 @@ gic = f # pps determines whether pass timings are printed pps = f +# Explicit ".exe" needed for WSL +ifeq ($(OS),Windows_NT) + ExeSuffix = .exe +else + ExeSuffix = +endif + # The following control where files sit and typically don't need to be changed, except # that Scheme and SCHEMEHEAPDIRS are set by Mf-cross to point to the host Scheme # implementation -Scheme = ../bin/$m/scheme +Scheme = ../bin/$m/scheme${ExeSuffix} export SCHEMEHEAPDIRS=../boot/%m # Define the libdirs separator character @@ -278,7 +285,7 @@ checkboot: '(#%$$fasl-file-equal? "../boot/$m/sbb" "../boot/$m/petite.boot" #t)'\ '(#%$$fasl-file-equal? "../boot/$m/scb" "../boot/$m/scheme.boot" #t)'\ '(printf "bootfile comparison succeeded\n"))'\ - | ../bin/$m/scheme -b ../boot/$m/sbb -q + | ../bin/$m/scheme${ExeSuffix} -b ../boot/$m/sbb -q xcheckboot: ${macroobj} ${patchfile} @echo '(reset-handler abort)'\ diff --git a/workarea b/workarea index efe290a866..31bfda6115 100755 --- a/workarea +++ b/workarea @@ -133,6 +133,12 @@ fi if [ ! -e $W/c/Mf-config ] ; then touch $W/c/Mf-config fi +case $M in + *nt) + (cd $W/c; workln ../../c/vs.bat vs.bat) + ;; +esac + workdir $W/s (cd $W/s; workln ../../s/Mf-$M Mf-$M) @@ -147,6 +153,11 @@ workdir $W/mats (cd $W/mats; forceworkln Mf-$M Makefile) (cd $W/mats; workln ../../mats/Mf-base Mf-base) (cd $W/mats; workln ../../mats/Mf-exobj Mf-exobj) +case $M in + *nt) + (cd $W/mats; workln ../../mats/vs.bat vs.bat) + ;; +esac for dir in `echo examples unicode` ; do workdir $W/$dir From caa5949dc2a757b68f4afd711281133ae7b0ba14 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Fri, 21 Apr 2017 23:25:56 -0300 Subject: [PATCH 2/8] more optimizations for map and for-each with explicit list extend the reductions for map and for-each when the arguments are explicit lists like (list 1 2 3 ...) or '(1 2 3 ...). cp0.ss 4.ms original commit: 4522ccdabd461370ad2d3fa91a92be0e6798d4d8 --- LOG | 4 + mats/4.ms | 209 ++++++++++++++++++++++++++++++++++++++++-- s/cp0.ss | 266 +++++++++++++++++++++++++++++------------------------- 3 files changed, 347 insertions(+), 132 deletions(-) diff --git a/LOG b/LOG index 922b7b077f..b9caec252a 100644 --- a/LOG +++ b/LOG @@ -456,3 +456,7 @@ - fix overflow detection for fxsll, fxarithmetic-shift-left, and fxarithmetic-shift library.ss, fx.ms, release_notes.stex +- more optimizations for map and for-each with explicit list + extend the reductions for map and for-each when the arguments are + explicit lists like (list 1 2 3 ...) or '(1 2 3 ...). + cp0.ss 4.ms diff --git a/mats/4.ms b/mats/4.ms index 777fd76884..b95a3bc981 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1102,7 +1102,7 @@ (expand/optimize '(begin (#3%map cons '(5 4 3 2 1 0)) 7))) 7)) - ;; map with lambda exp as procedure and lists in the form (list e0 e1 ... en) + ;; map with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en) ;; avoid creating each list and doing the actual map (equivalent-expansion? (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) @@ -1120,6 +1120,38 @@ (list 4 5 6) (list '(7) '(8) '(9))))) '(#3%list 12 15 18)) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(map (lambda (x y z) (apply + x y z)) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(#2%list 12 15 18)) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(map (lambda (x y z) (apply + x y z)) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(#3%list 12 15 18)) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(map (lambda (x y z) (apply + x y z)) + '(1 2 3) + '(4 5 6) + '((7) (8) (9))))) + '(#2%list 12 15 18)) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(map (lambda (x y z) (apply + x y z)) + '(1 2 3) + '(4 5 6) + '((7) (8) (9))))) + '(#3%list 12 15 18)) (equivalent-expansion? (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize @@ -1179,12 +1211,51 @@ (begin (write 'a) (list (begin (write 'b) 'g) 'j)) (begin (write 'c) (list (begin (write 'd) 'h) 'k)) (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))) - '("abcdef((g h . i) (j k . l))\n" - "abefcd((g h . i) (j k . l))\n" - "cdabef((g h . i) (j k . l))\n" - "cdefab((g h . i) (j k . l))\n" - "efabcd((g h . i) (j k . l))\n" - "efcdab((g h . i) (j k . l))\n")) + '("abcdef((g h . i) (j k . l))\n" + "abefcd((g h . i) (j k . l))\n" + "cdabef((g h . i) (j k . l))\n" + "cdefab((g h . i) (j k . l))\n" + "efabcd((g h . i) (j k . l))\n" + "efcdab((g h . i) (j k . l))\n")) + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (pretty-print (map (lambda (x y z) (cons* x y z)) + (begin (write 'ab) '(g j)) + (begin (write 'c) (list (begin (write 'd) 'h) 'k)) + (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))) + '("abcdef((g h . i) (j k . l))\n" + "abefcd((g h . i) (j k . l))\n" + "cdabef((g h . i) (j k . l))\n" + "cdefab((g h . i) (j k . l))\n" + "efabcd((g h . i) (j k . l))\n" + "efcdab((g h . i) (j k . l))\n")) + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (pretty-print (map (lambda (x y z) (cons* x y z)) + (begin (write 'a) (list (begin (write 'b) 'g) 'j)) + (begin (write 'cd) '(h k)) + (begin (write 'e) (list (begin (write 'f) 'i) 'l)))))) + '("abcdef((g h . i) (j k . l))\n" + "abefcd((g h . i) (j k . l))\n" + "cdabef((g h . i) (j k . l))\n" + "cdefab((g h . i) (j k . l))\n" + "efabcd((g h . i) (j k . l))\n" + "efcdab((g h . i) (j k . l))\n")) + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (pretty-print (map (lambda (x y z) (cons* x y z)) + (begin (write 'a) (list (begin (write 'b) 'g) 'j)) + (begin (write 'c) (list (begin (write 'd) 'h) 'k)) + (begin (write 'ef) '(i l)))))) + '("abcdef((g h . i) (j k . l))\n" + "abefcd((g h . i) (j k . l))\n" + "cdabef((g h . i) (j k . l))\n" + "cdefab((g h . i) (j k . l))\n" + "efabcd((g h . i) (j k . l))\n" + "efcdab((g h . i) (j k . l))\n")) ) (mat fold-left @@ -1875,6 +1946,130 @@ (expand/optimize '(#3%for-each cons '(5 4 3 2 1 0)))) '(#2%void))) + ;; for-each with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en) + ;; avoid creating each list and doing the actual for-each + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + (list 1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#2%display 12) (#2%display 15) (#2%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + (list 1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#3%display 12) (#3%display 15) (#3%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#2%display 12) (#2%display 15) (#2%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#3%display 12) (#3%display 15) (#3%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + '(1 2 3) + '(4 5 6) + '((7) (8) (9))))) + '(begin (#2%display 12) (#2%display 15) (#2%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + '(1 2 3) + '(4 5 6) + '((7) (8) (9))))) + '(begin (#3%display 12) (#3%display 15) (#3%display 18))) + (equal? + (with-output-to-string + (lambda () + (for-each (begin (write 'ab) (lambda (x y) (write (cons x y)))) + (begin (write 'a) (list (begin (write 'b) 'c))) + (begin (write 'a) (list (begin (write 'b) 'd)))))) + "ababab(c . d)") + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (for-each (lambda (x y) (write (cons x y))) + (list (begin (write 'a) 'c) (begin (write 'b) 'd)) + (list (begin (write 'x) 'e) (begin (write 'y) 'f))))) + ; lots of valid possibilities, but make sure we don't interleave and get, e.g., axby + '("abxy(c . e)(d . f)" + "abyx(c . e)(d . f)" + "baxy(c . e)(d . f)" + "bayx(c . e)(d . f)" + "xyab(c . e)(d . f)" + "yxab(c . e)(d . f)" + "xyba(c . e)(d . f)" + "yxba(c . e)(d . f)")) + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (for-each (lambda (x y z) (write (cons* x y z))) + (begin (write 'a) (list (begin (write 'b) 'g) 'j)) + (begin (write 'c) (list (begin (write 'd) 'h) 'k)) + (begin (write 'e) (list (begin (write 'f) 'i) 'l))))) + '("abcdef(g h . i)(j k . l)" + "abefcd(g h . i)(j k . l)" + "cdabef(g h . i)(j k . l)" + "cdefab(g h . i)(j k . l)" + "efabcd(g h . i)(j k . l)" + "efcdab(g h . i)(j k . l)")) + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (for-each (lambda (x y z) (write (cons* x y z))) + (begin (write 'ab) '(g j)) + (begin (write 'c) (list (begin (write 'd) 'h) 'k)) + (begin (write 'e) (list (begin (write 'f) 'i) 'l))))) + '("abcdef(g h . i)(j k . l)" + "abefcd(g h . i)(j k . l)" + "cdabef(g h . i)(j k . l)" + "cdefab(g h . i)(j k . l)" + "efabcd(g h . i)(j k . l)" + "efcdab(g h . i)(j k . l)")) + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (for-each (lambda (x y z) (write (cons* x y z))) + (begin (write 'a) (list (begin (write 'b) 'g) 'j)) + (begin (write 'cd) '(h k)) + (begin (write 'e) (list (begin (write 'f) 'i) 'l))))) + '("abcdef(g h . i)(j k . l)" + "abefcd(g h . i)(j k . l)" + "cdabef(g h . i)(j k . l)" + "cdefab(g h . i)(j k . l)" + "efabcd(g h . i)(j k . l)" + "efcdab(g h . i)(j k . l)")) + ((lambda (x ls) (and (member x ls) #t)) + (with-output-to-string + (lambda () + (for-each (lambda (x y z) (write (cons* x y z))) + (begin (write 'a) (list (begin (write 'b) 'g) 'j)) + (begin (write 'c) (list (begin (write 'd) 'h) 'k)) + (begin (write 'ef) '(i l))))) + '("abcdef(g h . i)(j k . l)" + "abefcd(g h . i)(j k . l)" + "cdabef(g h . i)(j k . l)" + "cdefab(g h . i)(j k . l)" + "efabcd(g h . i)(j k . l)" + "efcdab(g h . i)(j k . l)")) ) (mat ormap diff --git a/s/cp0.ss b/s/cp0.ss index 4b9fe4738e..a200ab1fc4 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3565,21 +3565,26 @@ (lambda (?ls) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) [(quote ,d) (null? d)] + [(call ,preinfo ,e ,e* ...) + ; check also for `(list)`. It should have been reduced to `(quote ())` before, + ; but cp0 isn't guaranteed to reach a fixed point. + (and (primref? e) (eq? (primref-name e) 'list) (null? e*))] [else #f]))) (define inline-lists - (lambda (?p ?ls ?ls* lvl ctxt sc wd name moi) - ; (map proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => + (lambda (?p ?ls ?ls* lvl map? ctxt sc wd name moi) + ; (map/for-each proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => ; (let ([p proc]) ; (let ([t21 a21] [t22 a22] ... [t2m a2m]) ; ... ; (let ([tn1 an1] [tn2 an2] ... [tnm anm]) - ; (list (p a11 t21 ... tn1) - ; (p a12 t22 ... tn2) - ; ... - ; (p a1m t2m ... tnm))))) - (let loop ([ls* (cons ?ls ?ls*)] [e** '()]) + ; (list/begin (p a11 t21 ... tn1) + ; (p a12 t22 ... tn2) + ; ... + ; (p a1m t2m ... tnm))))) + (let loop ([ls* (cons ?ls ?ls*)] [e** '()] [all-quoted? #t]) (if (null? ls*) (and (apply = (map length e**)) + (or (not all-quoted?) (fx<= (length (car e**)) 4)) (let* ([e** (reverse e**)] [e* (car e**)] [e** (cdr e**)]) (residualize-seq (list* ?p ?ls ?ls*) '() ctxt) (let ([p (cp0-make-temp (fx> (length e*) 1))] @@ -3590,20 +3595,25 @@ (let f ([t** temp**] [e** e**] [ls* ?ls*]) (if (null? t**) (non-result-exp (value-visit-operand! ?ls) - (build-primcall lvl 'list - (let ([preinfo (app-preinfo ctxt)]) - (let g ([e* e*] [t** temp**]) - (if (null? e*) - '() - (cons `(call ,preinfo (ref #f ,p) ,(car e*) - ,(map (lambda (t*) (build-ref (car t*))) t**) ...) - (g (cdr e*) (map cdr t**)))))))) + (let ([results + (let ([preinfo (app-preinfo ctxt)]) + (let g ([e* e*] [t** temp**]) + (if (null? e*) + '() + (cons `(call ,preinfo (ref #f ,p) ,(car e*) + ,(map (lambda (t*) (build-ref (car t*))) t**) ...) + (g (cdr e*) (map cdr t**))))))]) + (if map? + (build-primcall lvl 'list results) + (make-seq* ctxt results)))) (non-result-exp (value-visit-operand! (car ls*)) (build-let (car t**) (car e**) (f (cdr t**) (cdr e**) (cdr ls*)))))))))) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! (car ls*))) + [(quote ,d) + (and (list? d) (loop (cdr ls*) (cons (map (lambda (x) `(quote ,x)) d) e**) all-quoted?))] [(call ,preinfo ,e ,e* ...) - (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**)))] + (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**) #f))] [else #f]))))) (define-inline 2 map [(?p ?ls . ?ls*) @@ -3611,14 +3621,13 @@ (begin (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) null-rec) - (inline-lists ?p ?ls ?ls* 2 ctxt sc wd name moi))]) + (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi))]) (define-inline 3 map [(?p ?ls . ?ls*) (cond [(ormap null-rec? (cons ?ls ?ls*)) - (begin - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - null-rec)] + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + null-rec] ; could treat map in effect context as for-each, but don't because (our) ; map is guaranteed (even at optimization level 3) not to get sick if an ; input list is mutated, while for-each is not. @@ -3628,15 +3637,18 @@ (and (if (all-set? (prim-mask unsafe) flags) (all-set? (prim-mask discard) flags) (all-set? (prim-mask (or discard unrestricted)) flags)) - (arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))] + (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))] [else #f])) ; discard effect-free calls to map in effect context (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) void-rec] + [(inline-lists ?p ?ls ?ls* 3 #t ctxt sc wd name moi)] [(ormap (lambda (?ls) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) [(quote ,d) - (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] + (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] + [(call ,preinfo ,e ,e* ...) + (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))] [else #f])) (cons ?ls ?ls*)) => (lambda (n) @@ -3681,7 +3693,7 @@ ls*) ...) ropnd*)))))))) ctxt empty-env sc wd name moi))] - [else (inline-lists ?p ?ls ?ls* 3 ctxt sc wd name moi)])]) + [else #f])]) (define-inline 2 for-each [(?p ?ls . ?ls*) @@ -3689,110 +3701,114 @@ [(andmap null-rec? (cons ?ls ?ls*)) (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) void-rec] - [else #f])]) - ) - (define-inline 3 for-each - [(?p ?ls . ?ls*) - (cond - [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p)) - [,pr (let ([flags (primref-flags pr)]) - (and (if (all-set? (prim-mask unsafe) flags) - (all-set? (prim-mask discard) flags) - (all-set? (prim-mask (or discard unrestricted)) flags)) - (arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))] - [else #f]) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec] - [(ormap (lambda (?ls) - (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) - [(quote ,d) - (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] - [else #f])) - (cons ?ls ?ls*)) => - (lambda (n) - (cond - [(fx= n 0) + [else + (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])]) + (define-inline 3 for-each + [(?p ?ls . ?ls*) + (cond + [(ormap null-rec? (cons ?ls ?ls*)) ; (for-each proc e1 ... (begin e2 ... '()) e3 ...) => ; (begin e1 ... (begin e2 ... '()) e3 ... (void)) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec] - [else - ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...) - ; ((lambda (p ls ...) - ; (proc (car ls) ...) - ; (let ([t1 (cdr ls)] ...) - ; (proc (car t1) ...) - ; (let ([t2 (cdr t1)] ...) - ; (proc (car t2) ...) - ; (proc (cadr t2) ...)))) - ; proc e1 ... (begin e2 ... '(a b c d)) e3 ...) - (cp0 - (let ([p (cp0-make-temp (fx> n 1))] - [ls* (cons (cp0-make-temp #t) - (map (lambda (x) (cp0-make-temp #t)) ?ls*))]) - (build-lambda (cons p ls*) - (cond - [(fx= n 1) - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...)] - [else - (let f ([n n] [ls* ls*]) - (if (fx= n 2) - (make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'cadr (list (build-ref x)))) - ls*) ...)) - (make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) - (build-let tls* - (map (lambda (x) - (build-primcall 3 'cdr (list (build-ref x)))) - ls*) - (f (fx- n 1) tls*))))))]))) - ctxt empty-env sc wd name moi)]))] - [else - (and likely-to-be-compiled? - (cp0 - (let ([?ls* (cons ?ls ?ls*)]) - (let ([p (cp0-make-temp #t)] - [r (cp0-make-temp #t)] - [do (cp0-make-temp #t)] - [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)] - [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]) - (build-lambda (cons p tls*) - `(if ,(build-primcall 3 'null? - (list (build-ref (car tls*)))) - ,void-rec - ,(build-named-let do ls* - (map build-ref tls*) - (build-let (list r) - (list (build-primcall 3 'cdr (list (build-ref (car ls*))))) - `(if ,(build-primcall 3 'null? (list (build-ref r))) - (call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - ,(make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r) - ,(map (lambda (x) - (build-primcall 3 'cdr (list (build-ref x)))) - (cdr ls*)) ...))))))))) - ctxt empty-env sc wd name moi))])]) + (begin + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + void-rec)] + [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p)) + [,pr (let ([flags (primref-flags pr)]) + (and (if (all-set? (prim-mask unsafe) flags) + (all-set? (prim-mask discard) flags) + (all-set? (prim-mask (or discard unrestricted)) flags)) + (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))] + [else #f]) + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + void-rec] + [(inline-lists ?p ?ls ?ls* 3 #f ctxt sc wd name moi)] + [(ormap (lambda (?ls) + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) + [(quote ,d) + (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] + [(call ,preinfo ,e ,e* ...) + (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))] + [else #f])) + (cons ?ls ?ls*)) => + (lambda (n) + (safe-assert (not (= n 0))) ; guaranteed before we get here + ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...) + ; ((lambda (p ls ...) + ; (proc (car ls) ...) + ; (let ([t1 (cdr ls)] ...) + ; (proc (car t1) ...) + ; (let ([t2 (cdr t1)] ...) + ; (proc (car t2) ...) + ; (proc (cadr t2) ...)))) + ; proc e1 ... (begin e2 ... '(a b c d)) e3 ...) + (cp0 + (let ([p (cp0-make-temp (fx> n 1))] + [ls* (cons (cp0-make-temp #t) + (map (lambda (x) (cp0-make-temp #t)) ?ls*))]) + (build-lambda (cons p ls*) + (cond + [(fx= n 1) + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...)] + [else + (let f ([n n] [ls* ls*]) + (if (fx= n 2) + (make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'cadr (list (build-ref x)))) + ls*) ...)) + (make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) + (build-let tls* + (map (lambda (x) + (build-primcall 3 'cdr (list (build-ref x)))) + ls*) + (f (fx- n 1) tls*))))))]))) + ctxt empty-env sc wd name moi))] + [else + (and likely-to-be-compiled? + (cp0 + (let ([?ls* (cons ?ls ?ls*)]) + (let ([p (cp0-make-temp #t)] + [r (cp0-make-temp #t)] + [do (cp0-make-temp #t)] + [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)] + [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]) + (build-lambda (cons p tls*) + `(if ,(build-primcall 3 'null? + (list (build-ref (car tls*)))) + ,void-rec + ,(build-named-let do ls* + (map build-ref tls*) + (build-let (list r) + (list (build-primcall 3 'cdr (list (build-ref (car ls*))))) + `(if ,(build-primcall 3 'null? (list (build-ref r))) + (call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + ,(make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r) + ,(map (lambda (x) + (build-primcall 3 'cdr (list (build-ref x)))) + (cdr ls*)) ...))))))))) + ctxt empty-env sc wd name moi))])]) + ) (define-inline 3 vector-map [(?p ?v . ?v*) From db9248a73ecca7bc5bd67967a8cff0355c3d2fff Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Tue, 6 Jun 2017 18:25:22 -0300 Subject: [PATCH 3/8] fix signature of fxbit-set? primdata.ss original commit: 517ee9d86e974abba5a5a25945b677b4f5b35469 --- LOG | 2 ++ s/primdata.ss | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/LOG b/LOG index f3954e4524..4b2a560ee1 100644 --- a/LOG +++ b/LOG @@ -477,3 +477,5 @@ - fix strip-fasl-file for immutable strings and vectors, fix an $oops call, and fix a vector-index increment in hashing strip.ss, 7.ss, newhash.ss, misc.ms +- fix signature of fxbit-set? + primdata.ss diff --git a/s/primdata.ss b/s/primdata.ss index b44d108457..3e013e4d12 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -72,7 +72,7 @@ (fxbit-count [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxlength [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) (fxfirst-bit-set [sig [(fixnum) -> (fixnum)]] [flags arith-op cp02]) - (fxbit-set? [sig [(fixnum sub-ufixnum) -> (fixnum)]] [flags pure cp02]) + (fxbit-set? [sig [(fixnum sub-ufixnum) -> (boolean)]] [flags pure cp02]) (fxcopy-bit [sig [(fixnum sub-ufixnum bit) -> (fixnum)]] [flags arith-op cp02]) (fxbit-field [sig [(fixnum sub-ufixnum sub-ufixnum) -> (fixnum)]] [flags arith-op cp02 cp03]) (fxcopy-bit-field [sig [(fixnum sub-ufixnum sub-ufixnum fixnum) -> (fixnum)]] [flags arith-op cp02]) From 74f0518c891e3d6b78c8e514d0feef1ce5ce56c4 Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 8 Jun 2017 01:06:29 -0400 Subject: [PATCH 4/8] reverted to the preceding version of cp0 due to failure to preserve the expected evaluation order in one of the mats; removed the corresponding equivalent-expansion tests. cp0.ss, 4.ms rebuild boot files original commit: 63c6ae5c2d4354a984bfc210f061c2c2123f0439 --- LOG | 7 +- mats/4.ms | 64 ------------- s/cp0.ss | 266 +++++++++++++++++++++++++----------------------------- 3 files changed, 131 insertions(+), 206 deletions(-) diff --git a/LOG b/LOG index cf2705392e..1a976e7c97 100644 --- a/LOG +++ b/LOG @@ -483,4 +483,9 @@ extend the reductions for map and for-each when the arguments are explicit lists like (list 1 2 3 ...) or '(1 2 3 ...). cp0.ss, - 4.ms \ No newline at end of file + 4.ms +- reverted to the preceding version of cp0 due to failure to preserve + the expected evaluation order in one of the mats; removed the + corresponding equivalent-expansion tests. + cp0.ss, + 4.ms diff --git a/mats/4.ms b/mats/4.ms index 61efbee75a..9aa05e6284 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1120,30 +1120,6 @@ (list 4 5 6) (list '(7) '(8) '(9))))) '(#3%list 12 15 18)) - (equivalent-expansion? - (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(map (lambda (x y z) (apply + x y z)) - '(1 2 3) - (list 4 5 6) - (list '(7) '(8) '(9))))) - '(#2%list 12 15 18)) - (equivalent-expansion? - (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(map (lambda (x y z) (apply + x y z)) - '(1 2 3) - (list 4 5 6) - (list '(7) '(8) '(9))))) - '(#3%list 12 15 18)) - (equivalent-expansion? - (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(map (lambda (x y z) (apply + x y z)) - '(1 2 3) - '(4 5 6) - '((7) (8) (9))))) - '(#2%list 12 15 18)) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize @@ -1948,46 +1924,6 @@ '(#2%void))) ;; for-each with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en) ;; avoid creating each list and doing the actual for-each - (equivalent-expansion? - (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(for-each (lambda (x y z) (display (apply + x y z))) - (list 1 2 3) - (list 4 5 6) - (list '(7) '(8) '(9))))) - '(begin (#2%display 12) (#2%display 15) (#2%display 18))) - (equivalent-expansion? - (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(for-each (lambda (x y z) (display (apply + x y z))) - (list 1 2 3) - (list 4 5 6) - (list '(7) '(8) '(9))))) - '(begin (#3%display 12) (#3%display 15) (#3%display 18))) - (equivalent-expansion? - (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(for-each (lambda (x y z) (display (apply + x y z))) - '(1 2 3) - (list 4 5 6) - (list '(7) '(8) '(9))))) - '(begin (#2%display 12) (#2%display 15) (#2%display 18))) - (equivalent-expansion? - (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(for-each (lambda (x y z) (display (apply + x y z))) - '(1 2 3) - (list 4 5 6) - (list '(7) '(8) '(9))))) - '(begin (#3%display 12) (#3%display 15) (#3%display 18))) - (equivalent-expansion? - (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) - (expand/optimize - '(for-each (lambda (x y z) (display (apply + x y z))) - '(1 2 3) - '(4 5 6) - '((7) (8) (9))))) - '(begin (#2%display 12) (#2%display 15) (#2%display 18))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize diff --git a/s/cp0.ss b/s/cp0.ss index a200ab1fc4..4b9fe4738e 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3565,26 +3565,21 @@ (lambda (?ls) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) [(quote ,d) (null? d)] - [(call ,preinfo ,e ,e* ...) - ; check also for `(list)`. It should have been reduced to `(quote ())` before, - ; but cp0 isn't guaranteed to reach a fixed point. - (and (primref? e) (eq? (primref-name e) 'list) (null? e*))] [else #f]))) (define inline-lists - (lambda (?p ?ls ?ls* lvl map? ctxt sc wd name moi) - ; (map/for-each proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => + (lambda (?p ?ls ?ls* lvl ctxt sc wd name moi) + ; (map proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => ; (let ([p proc]) ; (let ([t21 a21] [t22 a22] ... [t2m a2m]) ; ... ; (let ([tn1 an1] [tn2 an2] ... [tnm anm]) - ; (list/begin (p a11 t21 ... tn1) - ; (p a12 t22 ... tn2) - ; ... - ; (p a1m t2m ... tnm))))) - (let loop ([ls* (cons ?ls ?ls*)] [e** '()] [all-quoted? #t]) + ; (list (p a11 t21 ... tn1) + ; (p a12 t22 ... tn2) + ; ... + ; (p a1m t2m ... tnm))))) + (let loop ([ls* (cons ?ls ?ls*)] [e** '()]) (if (null? ls*) (and (apply = (map length e**)) - (or (not all-quoted?) (fx<= (length (car e**)) 4)) (let* ([e** (reverse e**)] [e* (car e**)] [e** (cdr e**)]) (residualize-seq (list* ?p ?ls ?ls*) '() ctxt) (let ([p (cp0-make-temp (fx> (length e*) 1))] @@ -3595,25 +3590,20 @@ (let f ([t** temp**] [e** e**] [ls* ?ls*]) (if (null? t**) (non-result-exp (value-visit-operand! ?ls) - (let ([results - (let ([preinfo (app-preinfo ctxt)]) - (let g ([e* e*] [t** temp**]) - (if (null? e*) - '() - (cons `(call ,preinfo (ref #f ,p) ,(car e*) - ,(map (lambda (t*) (build-ref (car t*))) t**) ...) - (g (cdr e*) (map cdr t**))))))]) - (if map? - (build-primcall lvl 'list results) - (make-seq* ctxt results)))) + (build-primcall lvl 'list + (let ([preinfo (app-preinfo ctxt)]) + (let g ([e* e*] [t** temp**]) + (if (null? e*) + '() + (cons `(call ,preinfo (ref #f ,p) ,(car e*) + ,(map (lambda (t*) (build-ref (car t*))) t**) ...) + (g (cdr e*) (map cdr t**)))))))) (non-result-exp (value-visit-operand! (car ls*)) (build-let (car t**) (car e**) (f (cdr t**) (cdr e**) (cdr ls*)))))))))) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! (car ls*))) - [(quote ,d) - (and (list? d) (loop (cdr ls*) (cons (map (lambda (x) `(quote ,x)) d) e**) all-quoted?))] [(call ,preinfo ,e ,e* ...) - (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**) #f))] + (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**)))] [else #f]))))) (define-inline 2 map [(?p ?ls . ?ls*) @@ -3621,13 +3611,14 @@ (begin (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) null-rec) - (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi))]) + (inline-lists ?p ?ls ?ls* 2 ctxt sc wd name moi))]) (define-inline 3 map [(?p ?ls . ?ls*) (cond [(ormap null-rec? (cons ?ls ?ls*)) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - null-rec] + (begin + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + null-rec)] ; could treat map in effect context as for-each, but don't because (our) ; map is guaranteed (even at optimization level 3) not to get sick if an ; input list is mutated, while for-each is not. @@ -3637,18 +3628,15 @@ (and (if (all-set? (prim-mask unsafe) flags) (all-set? (prim-mask discard) flags) (all-set? (prim-mask (or discard unrestricted)) flags)) - (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))] + (arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))] [else #f])) ; discard effect-free calls to map in effect context (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) void-rec] - [(inline-lists ?p ?ls ?ls* 3 #t ctxt sc wd name moi)] [(ormap (lambda (?ls) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) [(quote ,d) - (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] - [(call ,preinfo ,e ,e* ...) - (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))] + (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] [else #f])) (cons ?ls ?ls*)) => (lambda (n) @@ -3693,7 +3681,7 @@ ls*) ...) ropnd*)))))))) ctxt empty-env sc wd name moi))] - [else #f])]) + [else (inline-lists ?p ?ls ?ls* 3 ctxt sc wd name moi)])]) (define-inline 2 for-each [(?p ?ls . ?ls*) @@ -3701,114 +3689,110 @@ [(andmap null-rec? (cons ?ls ?ls*)) (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) void-rec] - [else - (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])]) - (define-inline 3 for-each - [(?p ?ls . ?ls*) - (cond - [(ormap null-rec? (cons ?ls ?ls*)) + [else #f])]) + ) + (define-inline 3 for-each + [(?p ?ls . ?ls*) + (cond + [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p)) + [,pr (let ([flags (primref-flags pr)]) + (and (if (all-set? (prim-mask unsafe) flags) + (all-set? (prim-mask discard) flags) + (all-set? (prim-mask (or discard unrestricted)) flags)) + (arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))] + [else #f]) + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + void-rec] + [(ormap (lambda (?ls) + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) + [(quote ,d) + (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] + [else #f])) + (cons ?ls ?ls*)) => + (lambda (n) + (cond + [(fx= n 0) ; (for-each proc e1 ... (begin e2 ... '()) e3 ...) => ; (begin e1 ... (begin e2 ... '()) e3 ... (void)) - (begin - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec)] - [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p)) - [,pr (let ([flags (primref-flags pr)]) - (and (if (all-set? (prim-mask unsafe) flags) - (all-set? (prim-mask discard) flags) - (all-set? (prim-mask (or discard unrestricted)) flags)) - (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))] - [else #f]) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec] - [(inline-lists ?p ?ls ?ls* 3 #f ctxt sc wd name moi)] - [(ormap (lambda (?ls) - (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) - [(quote ,d) - (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] - [(call ,preinfo ,e ,e* ...) - (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))] - [else #f])) - (cons ?ls ?ls*)) => - (lambda (n) - (safe-assert (not (= n 0))) ; guaranteed before we get here - ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...) - ; ((lambda (p ls ...) - ; (proc (car ls) ...) - ; (let ([t1 (cdr ls)] ...) - ; (proc (car t1) ...) - ; (let ([t2 (cdr t1)] ...) - ; (proc (car t2) ...) - ; (proc (cadr t2) ...)))) - ; proc e1 ... (begin e2 ... '(a b c d)) e3 ...) - (cp0 - (let ([p (cp0-make-temp (fx> n 1))] - [ls* (cons (cp0-make-temp #t) - (map (lambda (x) (cp0-make-temp #t)) ?ls*))]) - (build-lambda (cons p ls*) - (cond - [(fx= n 1) - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...)] - [else - (let f ([n n] [ls* ls*]) - (if (fx= n 2) - (make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'cadr (list (build-ref x)))) - ls*) ...)) - (make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) - (build-let tls* - (map (lambda (x) - (build-primcall 3 'cdr (list (build-ref x)))) - ls*) - (f (fx- n 1) tls*))))))]))) - ctxt empty-env sc wd name moi))] - [else - (and likely-to-be-compiled? - (cp0 - (let ([?ls* (cons ?ls ?ls*)]) - (let ([p (cp0-make-temp #t)] - [r (cp0-make-temp #t)] - [do (cp0-make-temp #t)] - [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)] - [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]) - (build-lambda (cons p tls*) - `(if ,(build-primcall 3 'null? - (list (build-ref (car tls*)))) - ,void-rec - ,(build-named-let do ls* - (map build-ref tls*) - (build-let (list r) - (list (build-primcall 3 'cdr (list (build-ref (car ls*))))) - `(if ,(build-primcall 3 'null? (list (build-ref r))) - (call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - ,(make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r) - ,(map (lambda (x) - (build-primcall 3 'cdr (list (build-ref x)))) - (cdr ls*)) ...))))))))) - ctxt empty-env sc wd name moi))])]) - ) + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + void-rec] + [else + ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...) + ; ((lambda (p ls ...) + ; (proc (car ls) ...) + ; (let ([t1 (cdr ls)] ...) + ; (proc (car t1) ...) + ; (let ([t2 (cdr t1)] ...) + ; (proc (car t2) ...) + ; (proc (cadr t2) ...)))) + ; proc e1 ... (begin e2 ... '(a b c d)) e3 ...) + (cp0 + (let ([p (cp0-make-temp (fx> n 1))] + [ls* (cons (cp0-make-temp #t) + (map (lambda (x) (cp0-make-temp #t)) ?ls*))]) + (build-lambda (cons p ls*) + (cond + [(fx= n 1) + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...)] + [else + (let f ([n n] [ls* ls*]) + (if (fx= n 2) + (make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'cadr (list (build-ref x)))) + ls*) ...)) + (make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) + (build-let tls* + (map (lambda (x) + (build-primcall 3 'cdr (list (build-ref x)))) + ls*) + (f (fx- n 1) tls*))))))]))) + ctxt empty-env sc wd name moi)]))] + [else + (and likely-to-be-compiled? + (cp0 + (let ([?ls* (cons ?ls ?ls*)]) + (let ([p (cp0-make-temp #t)] + [r (cp0-make-temp #t)] + [do (cp0-make-temp #t)] + [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)] + [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]) + (build-lambda (cons p tls*) + `(if ,(build-primcall 3 'null? + (list (build-ref (car tls*)))) + ,void-rec + ,(build-named-let do ls* + (map build-ref tls*) + (build-let (list r) + (list (build-primcall 3 'cdr (list (build-ref (car ls*))))) + `(if ,(build-primcall 3 'null? (list (build-ref r))) + (call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + ,(make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r) + ,(map (lambda (x) + (build-primcall 3 'cdr (list (build-ref x)))) + (cdr ls*)) ...))))))))) + ctxt empty-env sc wd name moi))])]) (define-inline 3 vector-map [(?p ?v . ?v*) From a004a67b3f4da79ad52f663b47ad2a63f066f28c Mon Sep 17 00:00:00 2001 From: dyb Date: Thu, 8 Jun 2017 02:43:14 -0400 Subject: [PATCH 5/8] - restored the map and for-each optimizations with a fix for the evaluation-order bug. cp0.ss, 4.ms original commit: b395a763a3167c6a044273ea7deb000de35b0f09 --- LOG | 4 + mats/4.ms | 64 ++++++++ mats/patch-compile-0-f-t-f | 38 ++++- mats/patch-compile-0-t-f-f | 4 +- mats/patch-interpret-0-f-f-f | 4 +- mats/patch-interpret-0-f-t-f | 4 +- mats/patch-interpret-3-f-f-f | 4 +- mats/patch-interpret-3-f-t-f | 4 +- s/cp0.ss | 292 ++++++++++++++++++----------------- 9 files changed, 267 insertions(+), 151 deletions(-) diff --git a/LOG b/LOG index 1a976e7c97..5ed469245e 100644 --- a/LOG +++ b/LOG @@ -489,3 +489,7 @@ corresponding equivalent-expansion tests. cp0.ss, 4.ms +- restored the map and for-each optimizations with a fix for the + evaluation-order bug. + cp0.ss, + 4.ms diff --git a/mats/4.ms b/mats/4.ms index 9aa05e6284..61efbee75a 100644 --- a/mats/4.ms +++ b/mats/4.ms @@ -1120,6 +1120,30 @@ (list 4 5 6) (list '(7) '(8) '(9))))) '(#3%list 12 15 18)) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(map (lambda (x y z) (apply + x y z)) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(#2%list 12 15 18)) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(map (lambda (x y z) (apply + x y z)) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(#3%list 12 15 18)) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(map (lambda (x y z) (apply + x y z)) + '(1 2 3) + '(4 5 6) + '((7) (8) (9))))) + '(#2%list 12 15 18)) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize @@ -1924,6 +1948,46 @@ '(#2%void))) ;; for-each with lambda exp as procedure and lists in the form (list e0 e1 ... en) or '(e0 e1 ... en) ;; avoid creating each list and doing the actual for-each + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + (list 1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#2%display 12) (#2%display 15) (#2%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + (list 1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#3%display 12) (#3%display 15) (#3%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#2%display 12) (#2%display 15) (#2%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + '(1 2 3) + (list 4 5 6) + (list '(7) '(8) '(9))))) + '(begin (#3%display 12) (#3%display 15) (#3%display 18))) + (equivalent-expansion? + (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) + (expand/optimize + '(for-each (lambda (x y z) (display (apply + x y z))) + '(1 2 3) + '(4 5 6) + '((7) (8) (9))))) + '(begin (#2%display 12) (#2%display 15) (#2%display 18))) (equivalent-expansion? (parameterize ([optimize-level 3] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize diff --git a/mats/patch-compile-0-f-t-f b/mats/patch-compile-0-f-t-f index 1b11079849..f456c0fe97 100644 --- a/mats/patch-compile-0-f-t-f +++ b/mats/patch-compile-0-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-05-29 03:04:27.000000000 -0400 ---- errors-compile-0-f-t-f 2017-05-29 02:30:33.000000000 -0400 +*** errors-compile-0-f-f-f 2017-06-08 02:10:03.000000000 -0400 +--- errors-compile-0-f-t-f 2017-06-08 01:38:37.000000000 -0400 *************** *** 125,131 **** 3.mo:Expected error in mat dipa-letrec: "attempt to reference undefined variable a". @@ -58,6 +58,40 @@ 3.mo:Expected error in mat mrvs: "attempt to apply non-procedure 17". 3.mo:Expected error in mat mrvs: "returned two values to single value return context". *************** +*** 249,255 **** + 4.mo:Expected error in mat r6rs:case: "invalid syntax (r6rs:case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat r6rs:case: "invalid syntax (case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat named-let: "incorrect argument count in call ((letrec ((...)) x) 3 4)". +! 4.mo:Expected error in mat map: "map: 3 is not a procedure". + 4.mo:Expected error in mat map: "map: a is not a proper list". + 4.mo:Expected error in mat map: "map: (a . b) is not a proper list". + 4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular". +--- 249,255 ---- + 4.mo:Expected error in mat r6rs:case: "invalid syntax (r6rs:case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat r6rs:case: "invalid syntax (case (quote a) (a (quote yes)) (b (quote no)))". + 4.mo:Expected error in mat named-let: "incorrect argument count in call ((letrec ((...)) x) 3 4)". +! 4.mo:Expected error in mat map: "attempt to apply non-procedure 3". + 4.mo:Expected error in mat map: "map: a is not a proper list". + 4.mo:Expected error in mat map: "map: (a . b) is not a proper list". + 4.mo:Expected error in mat map: "map: (a a a a a a ...) is circular". +*************** +*** 319,325 **** + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". +! 4.mo:Expected error in mat for-each: "for-each: 3 is not a procedure". + 4.mo:Expected error in mat for-each: "for-each: a is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a . b) is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a a a a a a ...) is circular". +--- 319,325 ---- + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". + 4.mo:Expected error in mat fold-right: "fold-right: (a a a a a a ...) is circular". +! 4.mo:Expected error in mat for-each: "attempt to apply non-procedure 3". + 4.mo:Expected error in mat for-each: "for-each: a is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a . b) is not a proper list". + 4.mo:Expected error in mat for-each: "for-each: (a a a a a a ...) is circular". +*************** *** 3645,3651 **** misc.mo:Expected error in mat cpletrec: "foreign-procedure: no entry for "foo"". misc.mo:Expected error in mat cpletrec: "attempt to reference undefined variable q". diff --git a/mats/patch-compile-0-t-f-f b/mats/patch-compile-0-t-f-f index 3cbf9aae0e..b3795bc557 100644 --- a/mats/patch-compile-0-t-f-f +++ b/mats/patch-compile-0-t-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-05-29 03:04:27.000000000 -0400 ---- errors-compile-0-t-f-f 2017-05-29 02:38:26.000000000 -0400 +*** errors-compile-0-f-f-f 2017-06-08 02:10:03.000000000 -0400 +--- errors-compile-0-t-f-f 2017-06-08 01:45:53.000000000 -0400 *************** *** 93,99 **** 3.mo:Expected error in mat case-lambda: "incorrect number of arguments to #". diff --git a/mats/patch-interpret-0-f-f-f b/mats/patch-interpret-0-f-f-f index af6d3d9e2e..fdbbb9b59b 100644 --- a/mats/patch-interpret-0-f-f-f +++ b/mats/patch-interpret-0-f-f-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-f-f 2017-05-29 03:04:27.000000000 -0400 ---- errors-interpret-0-f-f-f 2017-05-29 02:47:10.000000000 -0400 +*** errors-compile-0-f-f-f 2017-06-08 02:10:03.000000000 -0400 +--- errors-interpret-0-f-f-f 2017-06-08 01:53:14.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". diff --git a/mats/patch-interpret-0-f-t-f b/mats/patch-interpret-0-f-t-f index 9b574165cb..3b08a510a6 100644 --- a/mats/patch-interpret-0-f-t-f +++ b/mats/patch-interpret-0-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-0-f-t-f 2017-05-29 02:30:33.000000000 -0400 ---- errors-interpret-0-f-t-f 2017-05-29 02:54:57.000000000 -0400 +*** errors-compile-0-f-t-f 2017-06-08 01:38:37.000000000 -0400 +--- errors-interpret-0-f-t-f 2017-06-08 02:00:50.000000000 -0400 *************** *** 1,7 **** primvars.mo:Expected error in mat make-parameter: "make-parameter: 2 is not a procedure". diff --git a/mats/patch-interpret-3-f-f-f b/mats/patch-interpret-3-f-f-f index ac9ad0085f..47d2dcead4 100644 --- a/mats/patch-interpret-3-f-f-f +++ b/mats/patch-interpret-3-f-f-f @@ -1,5 +1,5 @@ -*** errors-compile-3-f-f-f 2017-05-29 02:26:29.000000000 -0400 ---- errors-interpret-3-f-f-f 2017-05-29 03:10:12.000000000 -0400 +*** errors-compile-3-f-f-f 2017-06-08 01:35:00.000000000 -0400 +--- errors-interpret-3-f-f-f 2017-06-08 02:15:41.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/mats/patch-interpret-3-f-t-f b/mats/patch-interpret-3-f-t-f index 9178cd04c0..7f05db4eb3 100644 --- a/mats/patch-interpret-3-f-t-f +++ b/mats/patch-interpret-3-f-t-f @@ -1,5 +1,5 @@ -*** errors-compile-3-f-t-f 2017-05-29 02:34:27.000000000 -0400 ---- errors-interpret-3-f-t-f 2017-05-29 02:58:45.000000000 -0400 +*** errors-compile-3-f-t-f 2017-06-08 01:42:09.000000000 -0400 +--- errors-interpret-3-f-t-f 2017-06-08 02:04:33.000000000 -0400 *************** *** 1,3 **** --- 1,9 ---- diff --git a/s/cp0.ss b/s/cp0.ss index 4b9fe4738e..b86eec2770 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3565,45 +3565,53 @@ (lambda (?ls) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) [(quote ,d) (null? d)] + [(call ,preinfo ,e ,e* ...) + ; check also for `(list)`. It should have been reduced to `(quote ())` before, + ; but cp0 isn't guaranteed to reach a fixed point. + (and (primref? e) (eq? (primref-name e) 'list) (null? e*))] [else #f]))) (define inline-lists - (lambda (?p ?ls ?ls* lvl ctxt sc wd name moi) - ; (map proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => + (lambda (?p ?ls ?ls* lvl map? ctxt sc wd name moi) + ; (map/for-each proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => ; (let ([p proc]) - ; (let ([t21 a21] [t22 a22] ... [t2m a2m]) + ; (let ([t11 a11] ... [t1m a1m]) ; ... - ; (let ([tn1 an1] [tn2 an2] ... [tnm anm]) - ; (list (p a11 t21 ... tn1) - ; (p a12 t22 ... tn2) - ; ... - ; (p a1m t2m ... tnm))))) - (let loop ([ls* (cons ?ls ?ls*)] [e** '()]) + ; (let ([tn1 an1] ... [tnm anm]) + ; (list/begin (p t11 ... tn1) + ; (p t12 ... tn2) + ; ... + ; (p t1m ... tnm))))) + (let loop ([ls* (cons ?ls ?ls*)] [e** '()] [all-quoted? #t]) (if (null? ls*) (and (apply = (map length e**)) - (let* ([e** (reverse e**)] [e* (car e**)] [e** (cdr e**)]) + (or (not all-quoted?) (fx<= (length (car e**)) 4)) + (let ([p (cp0-make-temp (fx> (length (car e**)) 1))] + [temp** (map (lambda (e*) + (map (lambda (x) (cp0-make-temp #f)) e*)) + e**)]) (residualize-seq (list* ?p ?ls ?ls*) '() ctxt) - (let ([p (cp0-make-temp (fx> (length e*) 1))] - [temp** (map (lambda (e*) - (map (lambda (x) (cp0-make-temp #f)) e*)) - e**)]) - (build-let (list p) (list (value-visit-operand! ?p)) - (let f ([t** temp**] [e** e**] [ls* ?ls*]) - (if (null? t**) - (non-result-exp (value-visit-operand! ?ls) - (build-primcall lvl 'list - (let ([preinfo (app-preinfo ctxt)]) - (let g ([e* e*] [t** temp**]) - (if (null? e*) - '() - (cons `(call ,preinfo (ref #f ,p) ,(car e*) - ,(map (lambda (t*) (build-ref (car t*))) t**) ...) - (g (cdr e*) (map cdr t**)))))))) - (non-result-exp (value-visit-operand! (car ls*)) - (build-let (car t**) (car e**) - (f (cdr t**) (cdr e**) (cdr ls*)))))))))) + (build-let (list p) (list (value-visit-operand! ?p)) + (let f ([t** temp**] [e** (reverse e**)] [ls* (cons ?ls ?ls*)]) + (if (null? t**) + (let ([results + (let ([preinfo (app-preinfo ctxt)]) + (let g ([t** temp**]) + (if (null? (car t**)) + '() + (cons `(call ,preinfo (ref #f ,p) + ,(map (lambda (t*) (build-ref (car t*))) t**) ...) + (g (map cdr t**))))))]) + (if map? + (build-primcall lvl 'list results) + (make-seq* ctxt results))) + (non-result-exp (value-visit-operand! (car ls*)) + (build-let (car t**) (car e**) + (f (cdr t**) (cdr e**) (cdr ls*))))))))) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! (car ls*))) + [(quote ,d) + (and (list? d) (loop (cdr ls*) (cons (map (lambda (x) `(quote ,x)) d) e**) all-quoted?))] [(call ,preinfo ,e ,e* ...) - (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**)))] + (and (primref? e) (eq? (primref-name e) 'list) (loop (cdr ls*) (cons e* e**) #f))] [else #f]))))) (define-inline 2 map [(?p ?ls . ?ls*) @@ -3611,14 +3619,13 @@ (begin (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) null-rec) - (inline-lists ?p ?ls ?ls* 2 ctxt sc wd name moi))]) + (inline-lists ?p ?ls ?ls* 2 #t ctxt sc wd name moi))]) (define-inline 3 map [(?p ?ls . ?ls*) (cond [(ormap null-rec? (cons ?ls ?ls*)) - (begin - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - null-rec)] + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + null-rec] ; could treat map in effect context as for-each, but don't because (our) ; map is guaranteed (even at optimization level 3) not to get sick if an ; input list is mutated, while for-each is not. @@ -3628,15 +3635,18 @@ (and (if (all-set? (prim-mask unsafe) flags) (all-set? (prim-mask discard) flags) (all-set? (prim-mask (or discard unrestricted)) flags)) - (arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))] + (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))] [else #f])) ; discard effect-free calls to map in effect context (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) void-rec] + [(inline-lists ?p ?ls ?ls* 3 #t ctxt sc wd name moi)] [(ormap (lambda (?ls) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) [(quote ,d) - (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] + (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] + [(call ,preinfo ,e ,e* ...) + (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))] [else #f])) (cons ?ls ?ls*)) => (lambda (n) @@ -3681,7 +3691,7 @@ ls*) ...) ropnd*)))))))) ctxt empty-env sc wd name moi))] - [else (inline-lists ?p ?ls ?ls* 3 ctxt sc wd name moi)])]) + [else #f])]) (define-inline 2 for-each [(?p ?ls . ?ls*) @@ -3689,110 +3699,114 @@ [(andmap null-rec? (cons ?ls ?ls*)) (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) void-rec] - [else #f])]) - ) - (define-inline 3 for-each - [(?p ?ls . ?ls*) - (cond - [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p)) - [,pr (let ([flags (primref-flags pr)]) - (and (if (all-set? (prim-mask unsafe) flags) - (all-set? (prim-mask discard) flags) - (all-set? (prim-mask (or discard unrestricted)) flags)) - (arity-okay? (primref-arity pr) (+ (length ?ls*) 1))))] - [else #f]) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec] - [(ormap (lambda (?ls) - (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) - [(quote ,d) - (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] - [else #f])) - (cons ?ls ?ls*)) => - (lambda (n) - (cond - [(fx= n 0) + [else + (inline-lists ?p ?ls ?ls* 2 #f ctxt sc wd name moi)])]) + (define-inline 3 for-each + [(?p ?ls . ?ls*) + (cond + [(ormap null-rec? (cons ?ls ?ls*)) ; (for-each proc e1 ... (begin e2 ... '()) e3 ...) => ; (begin e1 ... (begin e2 ... '()) e3 ... (void)) - (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) - void-rec] - [else - ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...) - ; ((lambda (p ls ...) - ; (proc (car ls) ...) - ; (let ([t1 (cdr ls)] ...) - ; (proc (car t1) ...) - ; (let ([t2 (cdr t1)] ...) - ; (proc (car t2) ...) - ; (proc (cadr t2) ...)))) - ; proc e1 ... (begin e2 ... '(a b c d)) e3 ...) - (cp0 - (let ([p (cp0-make-temp (fx> n 1))] - [ls* (cons (cp0-make-temp #t) - (map (lambda (x) (cp0-make-temp #t)) ?ls*))]) - (build-lambda (cons p ls*) - (cond - [(fx= n 1) - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...)] - [else - (let f ([n n] [ls* ls*]) - (if (fx= n 2) - (make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'cadr (list (build-ref x)))) - ls*) ...)) - (make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) - (build-let tls* - (map (lambda (x) - (build-primcall 3 'cdr (list (build-ref x)))) - ls*) - (f (fx- n 1) tls*))))))]))) - ctxt empty-env sc wd name moi)]))] - [else - (and likely-to-be-compiled? - (cp0 - (let ([?ls* (cons ?ls ?ls*)]) - (let ([p (cp0-make-temp #t)] - [r (cp0-make-temp #t)] - [do (cp0-make-temp #t)] - [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)] - [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]) - (build-lambda (cons p tls*) - `(if ,(build-primcall 3 'null? - (list (build-ref (car tls*)))) - ,void-rec - ,(build-named-let do ls* - (map build-ref tls*) - (build-let (list r) - (list (build-primcall 3 'cdr (list (build-ref (car ls*))))) - `(if ,(build-primcall 3 'null? (list (build-ref r))) - (call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - ,(make-seq 'value - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car (list (build-ref x)))) - ls*) ...) - `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r) - ,(map (lambda (x) - (build-primcall 3 'cdr (list (build-ref x)))) - (cdr ls*)) ...))))))))) - ctxt empty-env sc wd name moi))])]) + (begin + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + void-rec)] + [(nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?p)) + [,pr (let ([flags (primref-flags pr)]) + (and (if (all-set? (prim-mask unsafe) flags) + (all-set? (prim-mask discard) flags) + (all-set? (prim-mask (or discard unrestricted)) flags)) + (arity-okay? (primref-arity pr) (fx+ (length ?ls*) 1))))] + [else #f]) + (residualize-seq '() (list* ?p ?ls ?ls*) ctxt) + void-rec] + [(inline-lists ?p ?ls ?ls* 3 #f ctxt sc wd name moi)] + [(ormap (lambda (?ls) + (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! ?ls)) + [(quote ,d) + (and (list? d) (let ([n (length d)]) (and (fx<= n 4) n)))] + [(call ,preinfo ,e ,e* ...) + (and (primref? e) (eq? (primref-name e) 'list) (let ([n (length e*)]) (and (fx<= n 4) n)))] + [else #f])) + (cons ?ls ?ls*)) => + (lambda (n) + (safe-assert (not (= n 0))) ; guaranteed before we get here + ; (for-each proc e1 ... (begin e2 ... '(a b c d)) e3 ...) + ; ((lambda (p ls ...) + ; (proc (car ls) ...) + ; (let ([t1 (cdr ls)] ...) + ; (proc (car t1) ...) + ; (let ([t2 (cdr t1)] ...) + ; (proc (car t2) ...) + ; (proc (cadr t2) ...)))) + ; proc e1 ... (begin e2 ... '(a b c d)) e3 ...) + (cp0 + (let ([p (cp0-make-temp (fx> n 1))] + [ls* (cons (cp0-make-temp #t) + (map (lambda (x) (cp0-make-temp #t)) ?ls*))]) + (build-lambda (cons p ls*) + (cond + [(fx= n 1) + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...)] + [else + (let f ([n n] [ls* ls*]) + (if (fx= n 2) + (make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'cadr (list (build-ref x)))) + ls*) ...)) + (make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) + (build-let tls* + (map (lambda (x) + (build-primcall 3 'cdr (list (build-ref x)))) + ls*) + (f (fx- n 1) tls*))))))]))) + ctxt empty-env sc wd name moi))] + [else + (and likely-to-be-compiled? + (cp0 + (let ([?ls* (cons ?ls ?ls*)]) + (let ([p (cp0-make-temp #t)] + [r (cp0-make-temp #t)] + [do (cp0-make-temp #t)] + [tls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)] + [ls* (map (lambda (x) (cp0-make-temp #t)) ?ls*)]) + (build-lambda (cons p tls*) + `(if ,(build-primcall 3 'null? + (list (build-ref (car tls*)))) + ,void-rec + ,(build-named-let do ls* + (map build-ref tls*) + (build-let (list r) + (list (build-primcall 3 'cdr (list (build-ref (car ls*))))) + `(if ,(build-primcall 3 'null? (list (build-ref r))) + (call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + ,(make-seq 'value + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car (list (build-ref x)))) + ls*) ...) + `(call ,(make-preinfo) (ref #f ,do) (ref #f ,r) + ,(map (lambda (x) + (build-primcall 3 'cdr (list (build-ref x)))) + (cdr ls*)) ...))))))))) + ctxt empty-env sc wd name moi))])]) + ) (define-inline 3 vector-map [(?p ?v . ?v*) From 0e41c9d8bee19bcd20239206a2e0fddd4eaa4d41 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 6 Jun 2017 10:48:11 -0400 Subject: [PATCH 6/8] Add `date-dst?` and `date-zone-name` procedures Accesses existing-but-hidden DST information in date records, and adds support for getting a name of the current time zone when a time zone offset is not explicitly provided. original commit: 3c8be62d12a8197018fb6c5aae182fd75da14fe8 --- LOG | 4 + c/stats.c | 111 ++-- csug/system.stex | 51 ++ mats/date.ms | 71 +- mats/patch-compile-0-f-f-t | 46 +- mats/patch-compile-0-f-t-t | 31 + mats/patch-compile-0-t-f-f | 26 +- mats/patch-compile-0-t-f-t | 44 -- mats/patch-compile-0-t-t-f | 4 +- mats/patch-compile-0-t-t-t | 0 mats/patch-compile-2-f-f-t | 50 +- mats/patch-compile-2-f-t-f | 28 +- mats/patch-compile-2-f-t-t | 31 + mats/patch-compile-2-t-f-f | 1034 ++++++++++++++++-------------- mats/patch-compile-2-t-f-t | 44 -- mats/patch-compile-2-t-t-f | 28 +- mats/patch-compile-2-t-t-t | 0 mats/patch-compile-3-f-t-t | 0 mats/patch-compile-3-t-t-t | 0 mats/patch-interpret-0-f-f-f | 4 +- mats/patch-interpret-0-f-t-f | 4 +- mats/patch-interpret-0-t-f-f | 8 +- mats/patch-interpret-0-t-t-f | 8 +- mats/patch-interpret-2-f-f-f | 65 +- mats/patch-interpret-2-f-t-f | 69 +- mats/patch-interpret-2-t-f-f | 61 +- mats/patch-interpret-2-t-t-f | 492 ++++++++++++++ mats/patch-interpret-3-t-f-f | 4 +- mats/patch-interpret-3-t-t-f | 4 +- mats/root-experr-compile-0-f-f-f | 9 +- mats/root-experr-compile-2-f-f-f | 9 +- release_notes/release_notes.stex | 8 + s/cmacros.ss | 3 +- s/date.ss | 49 +- s/primdata.ss | 6 +- 35 files changed, 1562 insertions(+), 844 deletions(-) create mode 100644 mats/patch-compile-0-f-t-t create mode 100644 mats/patch-compile-0-t-t-t create mode 100644 mats/patch-compile-2-f-t-t create mode 100644 mats/patch-compile-2-t-t-t create mode 100644 mats/patch-compile-3-f-t-t create mode 100644 mats/patch-compile-3-t-t-t create mode 100644 mats/patch-interpret-2-t-t-f diff --git a/LOG b/LOG index 5ed469245e..0977ded28c 100644 --- a/LOG +++ b/LOG @@ -493,3 +493,7 @@ evaluation-order bug. cp0.ss, 4.ms +- added date-dst? to access the previously-hidden DST information in + date records, and added date-zone-name to provide a time zone name. + date.ss, primdata.ss, stats.c, date.ms, root-experr*, + patch-compile*, system.stex diff --git a/c/stats.c b/c/stats.c index 708ce6b332..48034f3917 100644 --- a/c/stats.c +++ b/c/stats.c @@ -38,6 +38,8 @@ static struct timespec starting_mono_tp; +static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff); + /******** unique-id ********/ #if (time_t_bits == 32) @@ -326,16 +328,16 @@ ptr S_gmtime(ptr tzoff, ptr tspair) { } if (tzoff == Sfalse) { - struct tm tmx2; time_t tx2; if (localtime_r(&tx, &tmx) == NULL) return Sfalse; - if (gmtime_r(&tx, &tmx2) == NULL) return Sfalse; - tmx2.tm_isdst = tmx.tm_isdst; - if ((tx2 = mktime(&tmx2)) == (time_t)-1) return Sfalse; - INITVECTIT(dtvec, dtvec_tzoff) = S_integer_time_t(tx - tx2); + tmx.tm_isdst = -1; /* have mktime determine the DST status */ + if (mktime(&tmx) == (time_t)-1) return Sfalse; + (void) adjust_time_zone(dtvec, &tmx, Sfalse); } else { tx += Sinteger_value(tzoff); if (gmtime_r(&tx, &tmx) == NULL) return Sfalse; INITVECTIT(dtvec, dtvec_tzoff) = tzoff; + INITVECTIT(dtvec, dtvec_isdst) = Sfalse; + INITVECTIT(dtvec, dtvec_tzname) = Sfalse; } INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec); @@ -346,7 +348,6 @@ ptr S_gmtime(ptr tzoff, ptr tspair) { INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year); INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday); INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday); - INITVECTIT(dtvec, dtvec_isdst) = Sinteger(tmx.tm_isdst); return dtvec; } @@ -367,7 +368,7 @@ ptr S_asctime(ptr dtvec) { tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year)); tmx.tm_wday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_wday)); tmx.tm_yday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_yday)); - tmx.tm_isdst = (int)Sinteger_value(Svector_ref(dtvec, dtvec_isdst)); + tmx.tm_isdst = (int)Sboolean_value(Svector_ref(dtvec, dtvec_isdst)); if (asctime_r(&tmx, buf) == NULL) return Sfalse; } @@ -377,7 +378,8 @@ ptr S_asctime(ptr dtvec) { ptr S_mktime(ptr dtvec) { time_t tx; struct tm tmx; - long orig_tzoff = (long)UNFIX(INITVECTIT(dtvec, dtvec_tzoff)); + long orig_tzoff, tzoff; + ptr given_tzoff; tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec)); tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min)); @@ -386,18 +388,14 @@ ptr S_mktime(ptr dtvec) { tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1; tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year)); - tmx.tm_isdst = 0; + given_tzoff = INITVECTIT(dtvec, dtvec_tzoff); + if (given_tzoff == Sfalse) + orig_tzoff = 0; + else + orig_tzoff = (long)UNFIX(given_tzoff); + + tmx.tm_isdst = -1; /* have mktime determine the DST status */ if ((tx = mktime(&tmx)) == (time_t)-1) return Sfalse; - if (tmx.tm_isdst == 1) { /* guessed wrong */ - tmx.tm_sec = (int)Sinteger_value(Svector_ref(dtvec, dtvec_sec)); - tmx.tm_min = (int)Sinteger_value(Svector_ref(dtvec, dtvec_min)); - tmx.tm_hour = (int)Sinteger_value(Svector_ref(dtvec, dtvec_hour)); - tmx.tm_mday = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mday)); - tmx.tm_mon = (int)Sinteger_value(Svector_ref(dtvec, dtvec_mon)) - 1; - tmx.tm_year = (int)Sinteger_value(Svector_ref(dtvec, dtvec_year)); - tmx.tm_isdst = 1; - if ((tx = mktime(&tmx)) == (time_t)-1) return Sfalse; - } /* mktime may have normalized some values, set wday and yday */ INITVECTIT(dtvec, dtvec_sec) = Sinteger(tmx.tm_sec); @@ -408,29 +406,66 @@ ptr S_mktime(ptr dtvec) { INITVECTIT(dtvec, dtvec_year) = Sinteger(tmx.tm_year); INITVECTIT(dtvec, dtvec_wday) = Sinteger(tmx.tm_wday); INITVECTIT(dtvec, dtvec_yday) = Sinteger(tmx.tm_yday); -#ifdef WIN32 - { - TIME_ZONE_INFORMATION tz; - DWORD rc = GetTimeZoneInformation(&tz); - long tzoff; - switch (rc) { - case TIME_ZONE_ID_UNKNOWN: - case TIME_ZONE_ID_STANDARD: - tzoff = tz.Bias * -60; - break; - case TIME_ZONE_ID_DAYLIGHT: - tzoff = (tz.Bias + tz.DaylightBias) * -60; - break; - } - if (tzoff != orig_tzoff) tx = (time_t) difftime(tx, (time_t)(orig_tzoff - tzoff)); - } -#else - if (tmx.tm_gmtoff != orig_tzoff) tx = difftime(tx, (time_t)(orig_tzoff - tmx.tm_gmtoff)); -#endif + tzoff = adjust_time_zone(dtvec, &tmx, given_tzoff); + + if (tzoff != orig_tzoff) tx = (time_t) difftime(tx, (time_t)(orig_tzoff - tzoff)); + return Scons(S_integer_time_t(tx), Svector_ref(dtvec, dtvec_nsec)); } +static long adjust_time_zone(ptr dtvec, struct tm *tmxp, ptr given_tzoff) { + ptr tz_name = Sfalse; + long use_tzoff, tzoff; + +#ifdef WIN32 + { + TIME_ZONE_INFORMATION tz; + WCHAR *w_tzname; + int len; + + /* The ...ForYear() function is available on Windows Vista and later: */ + GetTimeZoneInformationForYear(tmxp->tm_year, NULL, &tz); + + if (tmxp->tm_isdst) { + tzoff = (tz.Bias + tz.DaylightBias) * -60; + w_tzname = tz.DaylightName; + } else { + tzoff = (tz.Bias + tz.StandardBias) * -60; + w_tzname = tz.StandardName; + } + + if (given_tzoff == Sfalse) { + len = (int)wcslen(w_tzname); + tz_name = S_string(NULL, len); + while (len--) + Sstring_set(tz_name, len, w_tzname[len]); + } + } +#else + tzoff = tmxp->tm_gmtoff; + if (given_tzoff == Sfalse) { +# if defined(__linux__) || defined(SOLARIS) + /* Linux and Solaris set `tzname`: */ + tz_name = S_string(tzname[tmxp->tm_isdst], -1); +# else + /* BSD variants add `tm_zone` in `struct tm`: */ + tz_name = S_string(tmxp->tm_zone, -1); +# endif + } +#endif + + if (given_tzoff == Sfalse) + use_tzoff = tzoff; + else + use_tzoff = (long)UNFIX(given_tzoff); + + INITVECTIT(dtvec, dtvec_isdst) = ((given_tzoff == Sfalse) ? Sboolean(tmxp->tm_isdst) : Sfalse); + INITVECTIT(dtvec, dtvec_tzoff) = FIX(use_tzoff); + INITVECTIT(dtvec, dtvec_tzname) = tz_name; + + return tzoff; +} /******** old real-time and cpu-time support ********/ diff --git a/csug/system.stex b/csug/system.stex index 5df66713fe..1da4578ef9 100644 --- a/csug/system.stex +++ b/csug/system.stex @@ -3984,15 +3984,25 @@ It must be an exact integer in the range $-86400$ to $+86400$, inclusive and defaults to the local time-zone offset. UTC may be obtained by passing an offset of zero. +If \var{offset} is not provided, then the current time zone's offset +is used, and \scheme{date-dst?} and \scheme{date-zone-name} report +information about the time zone. If \var{offset} is provided, then +\scheme{date-dst?} and \scheme{date-zone-name} on the resulting date +object produce \scheme{#f}. + The following examples assume the local time zone is EST. \schemedisplay (current-date) ;=> # (current-date 0) ;=> # + +(date-zone-name (current-date)) ;=> "EST" \var{or other system-provided string} +(date-zone-name (current-date 0)) ;=> #f \endschemedisplay %---------------------------------------------------------------------------- \entryheader +\formdef{make-date}{\categoryprocedure}{(make-date \var{nsec} \var{sec} \var{min} \var{hour} \var{day} \var{mon} \var{year})} \formdef{make-date}{\categoryprocedure}{(make-date \var{nsec} \var{sec} \var{min} \var{hour} \var{day} \var{mon} \var{year} \var{offset})} \returns a date object \listlibraries @@ -4015,9 +4025,18 @@ as described above. It must be an exact integer in the range $-86400$ to $+86400$, inclusive. UTC may be specified by passing an offset of zero. +If \var{offset} is not provided, then the current time zone's offset +is used, and \scheme{date-dst?} and \scheme{date-zone-name} report +information about the time zone. If \var{offset} is provided, then +\scheme{date-dst?} and \scheme{date-zone-name} on the resulting date +object produce \scheme{#f}. + \schemedisplay (make-date 0 0 0 0 1 1 1970 0) ;=> # (make-date 0 30 7 9 23 9 2007 -14400) ;=> # + +(date-zone-name (make-date 0 30 7 9 23 9 2007 -14400)) ;=> #f +(date-zone-name (make-date 0 30 7 9 23 9 2007)) ;=> "EDT" \var{or other system-provided string} \endschemedisplay %---------------------------------------------------------------------------- @@ -4097,6 +4116,32 @@ d2 ;=> # (date-year-day d2) ;=> 265 \endschemedisplay +%---------------------------------------------------------------------------- +\entryheader +\formdef{date-dst?}{\categoryprocedure}{(date-dst? \var{date})} +\returns whether \var{date} is in Daylight Saving Time +\formdef{date-zone-name}{\categoryprocedure}{(date-zone-name \var{date})} +\returns \scheme{#f} or a string naming the time zone of \var{date} +\listlibraries +\endentryheader + +These procedures report time-zone information for +the date represented by \var{date} for a date object that +is constructed without an explicit time-zone offset. When +a date object is created instead with explicit time-zone offset, +these procedures produce \scheme{#f}. + +Daylight Saving Time status for the current time zone and a name +string for the time zone are computed using platform-specific routines. +In particular, the format of the zone name is platform-specific. + +\schemedisplay +(define d (make-date 0 30 7 9 23 9 2007)) +(date-zone-offset d) ;=> -14400 \var{assuming Eastern U.S. time zone} +(date-dst? d) ;=> #t +(date-zone-name d) ;=> "EDT" \var{or some system-provided string} +\endschemedisplay + %---------------------------------------------------------------------------- \entryheader \formdef{time-utc->date}{\categoryprocedure}{(time-utc->date \var{time})} @@ -4119,6 +4164,12 @@ It must be an exact integer in the range $-86400$ to $+86400$, inclusive and defaults to the local time-zone offset. UTC may be obtained by passing an offset of zero. +If \var{offset} is not provided to \scheme{time-utc->date}, then the current time zone's offset +is used, and \scheme{date-dst?} and \scheme{date-zone-name} report +information about the time zone. If \var{offset} is provided, then +\scheme{date-dst?} and \scheme{date-zone-name} on the resulting date +object produce \scheme{#f}. + \schemedisplay (define d (make-date 0 30 7 9 23 9 2007 -14400)) (date->time-utc d) ;=> # diff --git a/mats/date.ms b/mats/date.ms index a7655c2337..bcadbe39c0 100644 --- a/mats/date.ms +++ b/mats/date.ms @@ -323,8 +323,6 @@ (make-date 0 0 0 0 1)) (error? ; wrong number of arguments (make-date 0 0 0 0 1 1)) - (error? ; wrong number of arguments - (make-date 0 0 0 0 1 1 2007)) (error? ; wrong number of arguments (make-date 0 0 0 0 1 1 2007 0 0)) (error? ; invalid nanosecond @@ -464,6 +462,14 @@ (date-year-day 17)) (error? ; not a date record (date-year-day $time-t1)) + (error? ; wrong number of arguments + (date-dst?)) + (error? ; wrong number of arguments + (date-dst? $date-d1 #t)) + (error? ; not a date record + (date-dst? 17)) + (error? ; not a date record + (date-dst? $time-t1)) (error? ; wrong number of arguments (date-zone-offset)) (error? ; wrong number of arguments @@ -472,6 +478,14 @@ (date-zone-offset 17)) (error? ; not a date record (date-zone-offset $time-t1)) + (error? ; wrong number of arguments + (date-zone-name)) + (error? ; wrong number of arguments + (date-zone-name $date-d1 #t)) + (error? ; not a date record + (date-zone-name 17)) + (error? ; not a date record + (date-zone-name $time-t1)) (error? ; wrong number of arguments (current-date 0 #t)) (error? ; invalid offset @@ -486,7 +500,10 @@ (and (date? $date-d3) (not (time? $date-d3)))) (begin (define $date-d4 (current-date (* 10 60 60))) - (and (date? $date-d4) (not (time? $date-d3)))) + (and (date? $date-d4) (not (time? $date-d4)))) + (begin + (define $date-d5 (make-date 0 1 1 1 15 6 2016)) + (and (date? $date-d5) (not (time? $date-d5)))) (date? (make-date 0 0 0 0 1 1 1970 -24)) (date? (make-date 999999999 59 59 23 31 12 2007 24)) (eqv? (date-nanosecond $date-d1) 1) @@ -497,6 +514,54 @@ (eqv? (date-month $date-d1) 6) (eqv? (date-year $date-d1) 1970) (eqv? (date-zone-offset $date-d1) 8) + (boolean? (date-dst? $date-d5)) + (fixnum? (date-zone-offset $date-d5)) + (eqv? (date-zone-name $date-d1) #f) + (or (string? (date-zone-name $date-d2)) + (not (date-zone-name $date-d2))) + (eqv? (date-zone-name $date-d3) #f) + (eqv? (date-zone-name $date-d4) #f) + (or (string? (date-zone-name $date-d5)) + (not (date-zone-name $date-d5))) + (begin + (define (plausible-dst? d) + ;; Recognize a few time zone names and correlate with the DST field. + ;; Names like "EST" appear on Unix variants, while the long names + ;; show up on Windows. + (cond + [(member (date-zone-name d) '("EST" "CST" "MST" "PST" + "Eastern Standard Time" + "Central Standard Time" + "Mountain Standard Time" + "Pacific Standard Time")) + (eqv? (date-dst? d) #f)] + [(member (date-zone-name d) '("EDT" "CDT" "MDT" "PDT" + "Eastern Daylight Time" + "Central Daylight Time" + "Mountain Daylight Time" + "Pacific Daylight Time")) + (eqv? (date-dst? d) #t)] + [else #t])) + (plausible-dst? $date-d5)) + (begin + (define $date-d6 (make-date 0 1 1 1 15 1 2016)) + (plausible-dst? $date-d6)) + ; check whether tz offsets are set according to DST, assuming that + ; DST always means a 1-hour shift + (let ([delta (time-second (time-difference (date->time-utc $date-d5) + (date->time-utc $date-d6)))] + [no-dst-delta (* 152 24 60 60)]; 152 days + [hour-delta (* 60 60)]) + (cond + [(and (date-dst? $date-d5) (not (date-dst? $date-d6))) + ;; Northern-hemisphere DST reduces delta + (= delta (- no-dst-delta hour-delta))] + [(and (not (date-dst? $date-d5)) (date-dst? $date-d6)) + ;; Southern-hemisphere DST increases delta + (= delta (+ no-dst-delta hour-delta))] + [else + ;; No DST or always DST + (= delta no-dst-delta)])) ; check to make sure dst isn't screwing with our explicitly created dates ; when we call mktime to fill in wday and yday (let f ([mon 1]) diff --git a/mats/patch-compile-0-f-f-t b/mats/patch-compile-0-f-f-t index 3a6d64b7d5..0384a2b3f0 100644 --- a/mats/patch-compile-0-f-f-t +++ b/mats/patch-compile-0-f-f-t @@ -1,47 +1,5 @@ -*** errors-compile-0-f-f-f 2017-05-28 20:37:09.000000000 -0400 ---- errors-compile-0-f-f-t 2017-05-28 20:47:43.000000000 -0400 -*************** -*** 3603,3609 **** - misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". - misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". - misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". -! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 5". - misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". - misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". - misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #". ---- 3603,3609 ---- - misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation -1". - misc.mo:Expected error in mat compute-composition: "compute-composition: invalid generation "static"". - misc.mo:Expected error in mat make-object-finder: "make-object-finder: 17 is not a procedure". -! misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation 7". - misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation oldgen". - misc.mo:Expected error in mat make-object-finder: "make-object-finder: invalid generation -1". - misc.mo:Expected error in mat make-object-finder: "incorrect number of arguments to #". -*************** -*** 7085,7095 **** - 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". -! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". -! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". -! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 5". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". ---- 7085,7095 ---- - 7.mo:Expected error in mat sstats: "set-sstats-gc-bytes!: twelve is not an exact integer". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation yuk". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation -1". -! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 7". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation ". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation #f". -! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 7". -! 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid generation 7". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". - 7.mo:Expected error in mat bytes-allocated: "bytes-allocated: invalid space gnu". +*** errors-compile-0-f-f-f 2017-06-06 15:52:54.089820649 -0400 +--- errors-compile-0-f-f-t 2017-06-06 15:55:15.167428881 -0400 *************** *** 8461,8473 **** fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". diff --git a/mats/patch-compile-0-f-t-t b/mats/patch-compile-0-f-t-t new file mode 100644 index 0000000000..d36940b1af --- /dev/null +++ b/mats/patch-compile-0-f-t-t @@ -0,0 +1,31 @@ +*** errors-compile-0-f-t-f 2017-06-06 15:57:35.377030441 -0400 +--- errors-compile-0-f-t-t 2017-06-06 15:59:53.402609438 -0400 +*************** +*** 8461,8473 **** + fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". + fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". +! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow with arguments and 2". + fx.mo:Expected error in mat fx*: "fx*: is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: <-int> is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". + fx.mo:Expected error in mat r6rs:fx*: "fx*: (a . b) is not a fixnum". +! fx.mo:Expected error in mat r6rs:fx*: "fx*: fixnum overflow with arguments and 2". + fx.mo:Expected error in mat r6rs:fx*: "fx*: is not a fixnum". + fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". + fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". +--- 8461,8473 ---- + fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". + fx.mo:Expected error in mat r6rs:fx-: "fx-: #f is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: (a . b) is not a fixnum". +! fx.mo:Expected error in mat fx*: "fx*: fixnum overflow computing (fx* 2)". + fx.mo:Expected error in mat fx*: "fx*: is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: <-int> is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". + fx.mo:Expected error in mat fx*: "fx*: #f is not a fixnum". + fx.mo:Expected error in mat r6rs:fx*: "fx*: (a . b) is not a fixnum". +! fx.mo:Expected error in mat r6rs:fx*: "fx*: fixnum overflow computing (fx* 2)". + fx.mo:Expected error in mat r6rs:fx*: "fx*: is not a fixnum". + fx.mo:Expected error in mat r6rs:fx*: "fx*: <-int> is not a fixnum". + fx.mo:Expected error in mat r6rs:fx*: "fx*: #f is not a fixnum". diff --git a/mats/patch-compile-0-t-f-f b/mats/patch-compile-0-t-f-f index b3795bc557..ea4110779d 100644 --- a/mats/patch-compile-0-t-f-f +++ b/mats/patch-compile-0-t-f-f @@ -5932,7 +5932,7 @@ date.mo:Expected error in mat time: "time>=?: # is not a time record". date.mo:Expected error in mat time: "time>=?: types of