diff --git a/.gitignore b/.gitignore index 18465bf810..9d2e67a7cc 100644 --- a/.gitignore +++ b/.gitignore @@ -3,24 +3,17 @@ .sw? /Makefile /TAGS -/a6le/ -/a6nt/ -/a6osx/ /bin/ -/i3le/ -/i3nt/ -/i3osx/ -/ta6le/ -/ta6nt/ -/ta6osx/ -/ti3le/ -/ti3nt/ -/ti3osx/ -/arm32le/ -/tarm32le/ -/tarm64le/ -/ppc32le/ -/tppc32le/ +/boot/ +/pb/ +/a6*/ +/i3*/ +/ta6*/ +/ti3*/ +/arm*/ +/tarm*/ +/ppc*/ +/tppc*/ /xc-*/ *.*run /csug/math/csug/ @@ -55,4 +48,3 @@ /release_notes/*.htoc /release_notes/*.log /release_notes/release_notes.pdf -/boot/ diff --git a/c/Mf-a6fb b/c/Mf-a6fb index d41132ec5c..d922dab4cc 100644 --- a/c/Mf-a6fb +++ b/c/Mf-a6fb @@ -13,15 +13,15 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6fb -Cpu = X86_64 +m ?= a6fb +Cpu ?= X86_64 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -lossp-uuid +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -41,7 +41,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6le b/c/Mf-a6le index a5c2792895..190f105eca 100644 --- a/c/Mf-a6le +++ b/c/Mf-a6le @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6le -Cpu = X86_64 +m ?= a6le +Cpu ?= X86_64 -mdclib = -lm -ldl ${ncursesLib} -lrt -luuid -C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} +mdclib = -lm -ldl ${ncursesLib} ${threadLibs} -lrt -luuid +C = ${CC} ${CPPFLAGS} -m64 -msse2 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -40,7 +40,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6nb b/c/Mf-a6nb index c32d363506..07657aebb7 100644 --- a/c/Mf-a6nb +++ b/c/Mf-a6nb @@ -13,15 +13,15 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6nb -Cpu = X86_64 +m ?= a6nb +Cpu ?= X86_64 mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/local/include -I/usr/X11R6/include -mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a ${threadLibs} +C = ${CC} ${CPPFLAGS} -m64 ${warningFlags} ${optFlags} -O ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -42,7 +42,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} paxctl +m ${Scheme} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6nt b/c/Mf-a6nt index 6dab00245b..0068e1ff66 100644 --- a/c/Mf-a6nt +++ b/c/Mf-a6nt @@ -13,8 +13,8 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6nt -Cpu = X86_64 +m ?= a6nt +Cpu ?= X86_64 clib= o = obj @@ -39,7 +39,7 @@ make.bat: vs.bat # ------------------------------------------------------- # For cross-compilation, triggered by setting cross=t o=o -C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} ${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid diff --git a/c/Mf-a6ob b/c/Mf-a6ob index cdd911cd24..09da9aed40 100644 --- a/c/Mf-a6ob +++ b/c/Mf-a6ob @@ -13,15 +13,15 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6ob -Cpu = X86_64 +m ?= a6ob +Cpu ?= X86_64 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O ${CFLAGS} +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -lossp-uuid +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -41,7 +41,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6osx b/c/Mf-a6osx index 54f13f0c71..deb4576d14 100644 --- a/c/Mf-a6osx +++ b/c/Mf-a6osx @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6osx -Cpu = X86_64 +m ?= a6osx +Cpu ?= X86_64 mdclib = -liconv -lm ${ncursesLib} -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -I/opt/X11/include/ ${CFLAGS} +C = ${CC} ${CPPFLAGS} -m64 ${warningFlags} ${optFlags} -I/opt/X11/include/ ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -40,7 +40,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-a6s2 b/c/Mf-a6s2 index 382edbeff1..e0150a8ca7 100644 --- a/c/Mf-a6s2 +++ b/c/Mf-a6s2 @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6s2 -Cpu = X86_64 +m ?= a6s2 +Cpu ?= X86_64 -mdclib = -lnsl -ldl -lm ${cursesLib} -lrt -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +mdclib = -lnsl -ldl -lm ${threadLibs} ${cursesLib} -lrt +C = ${CC} ${CPPFLAGS} -m64 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -40,7 +40,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ./configure --64) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m64" ${MAKE} liblz4.a) diff --git a/c/Mf-arm32le b/c/Mf-arm32le index 699f49a318..8397ca2913 100644 --- a/c/Mf-arm32le +++ b/c/Mf-arm32le @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = arm32le -Cpu = ARMV6 +m ?= arm32le +Cpu ?= ARMV6 -mdclib = -lm -ldl ${ncursesLib} -lrt -luuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} +mdclib = -lm -ldl ${ncursesLib} {$threadLibs} -lrt -luuid +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} o = o -mdsrc = arm32le.c -mdobj = arm32le.o +mdsrc ?= arm32le.c +mdobj ?= arm32le.o .SUFFIXES: .SUFFIXES: .c .o @@ -40,7 +40,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ${MAKE} liblz4.a) diff --git a/c/Mf-arm64le b/c/Mf-arm64le new file mode 100644 index 0000000000..e980858f0c --- /dev/null +++ b/c/Mf-arm64le @@ -0,0 +1,46 @@ +# Mf-arm64le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m ?= tarm64le +Cpu ?= AARCH64 + +mdclib = -lm -ldl ${ncursesLib} -lrt -luuid ${threadLibs} +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} +o = o +mdsrc ?= arm32le.c +mdobj ?= arm32le.o + +.SUFFIXES: +.SUFFIXES: .c .o + +.c.o: + $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c + +include Mf-base + +${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} + ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + +${KernelLib}: ${kernelobj} + ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} + +${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} + $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} + +../zlib/configure.log: + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ./configure) + +../lz4/lib/liblz4.a: ${LZ4Sources} + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags}" ${MAKE} liblz4.a) diff --git a/c/Mf-i3fb b/c/Mf-i3fb index 71aef4e42e..a614f038bb 100644 --- a/c/Mf-i3fb +++ b/c/Mf-i3fb @@ -13,15 +13,15 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3fb -Cpu = I386 +m ?= i3fb +Cpu ?= I386 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -lossp-uuid +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -41,7 +41,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3le b/c/Mf-i3le index 0bef92a7ce..11e726eae8 100644 --- a/c/Mf-i3le +++ b/c/Mf-i3le @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3le -Cpu = I386 +m ?= i3le +Cpu ?= I386 -mdclib = -lm -ldl ${ncursesLib} -lrt -luuid -C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -fno-stack-protector ${CFLAGS} +mdclib = -lm -ldl ${ncursesLib} ${threadLibs} -lrt -luuid +C = ${CC} ${CPPFLAGS} -m32 -msse2 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -40,7 +40,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3nb b/c/Mf-i3nb index 75db395d5f..70428c0203 100644 --- a/c/Mf-i3nb +++ b/c/Mf-i3nb @@ -13,15 +13,15 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3nb -Cpu = I386 +m ?= i3nb +Cpu ?= I386 mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include -mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O ${CFLAGS} +mdclib = /usr/lib/i18n/libiconv_std.a -lm ${threadLibs} /usr/pkg/lib/libncurses.a +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -32,7 +32,7 @@ mdobj = i3le.o include Mf-base ${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} + ${LD} -m elf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} ${KernelLib}: ${kernelobj} ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} @@ -42,7 +42,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} paxctl +m ${Scheme} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3nt b/c/Mf-i3nt index 8f0e8fee1f..b7dfd41b1f 100644 --- a/c/Mf-i3nt +++ b/c/Mf-i3nt @@ -13,8 +13,8 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3nt -Cpu = I386 +m ?= i3nt +Cpu ?= I386 clib= o = obj @@ -39,7 +39,7 @@ make.bat: vs.bat # ------------------------------------------------------- # For cross-compilation, triggered by setting cross=t o=o -C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${CFLAGS} -D__MINGW_USE_VC2005_COMPAT ${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid diff --git a/c/Mf-i3ob b/c/Mf-i3ob index 732f4b3629..912c3ad3eb 100644 --- a/c/Mf-i3ob +++ b/c/Mf-i3ob @@ -13,15 +13,15 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3ob -Cpu = I386 +m ?= i3ob +Cpu ?= I386 mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O ${CFLAGS} +mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} ${threadLibs} -lossp-uuid +C = ${CC} ${CPPFLAGS} ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -41,7 +41,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3osx b/c/Mf-i3osx index ea8060fc32..5f9be957a7 100644 --- a/c/Mf-i3osx +++ b/c/Mf-i3osx @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3osx -Cpu = I386 +m ?= i3osx +Cpu ?= I386 mdclib = -liconv -lm ${ncursesLib} -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} +C = ${CC} ${CPPFLAGS} -m32 -msse2 ${warningFlags} ${optFlags} -I/opt/X11/include/ ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o @@ -40,7 +40,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-i3qnx b/c/Mf-i3qnx index c55bf6cc72..ef2f87952b 100644 --- a/c/Mf-i3qnx +++ b/c/Mf-i3qnx @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3qnx -Cpu = I386 +m ?= i3qnx +Cpu ?= I386 mdclib = -lm /usr/local/lib/libiconv.so -lsocket ${ncursesLib} -C = qcc ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -N2048K ${CFLAGS} +C = qcc ${CPPFLAGS} -m32 -N2048K ${warningFlags} ${optFlags} ${CFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o LocalInclude = /usr/local/include .SUFFIXES: diff --git a/c/Mf-i3s2 b/c/Mf-i3s2 index 7741bab6bf..9f30aa1ca0 100644 --- a/c/Mf-i3s2 +++ b/c/Mf-i3s2 @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3s2 -Cpu = I386 +m ?= i3s2 +Cpu ?= I386 -mdclib = -lnsl -ldl -lm ${cursesLib} -lrt -C = ${CC} ${CFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O ${CPPFLAGS} +mdclib = -lnsl -ldl -lm ${cursesLib} ${threadLibs} -lrt +C = ${CC} ${CFLAGS} -m32 ${warningFlags} ${optFlags} ${threadFlags} ${CPPFLAGS} o = o -mdsrc = i3le.c -mdobj = i3le.o +mdsrc ?= i3le.c +mdobj ?= i3le.o .SUFFIXES: .SUFFIXES: .c .o diff --git a/c/Mf-pb b/c/Mf-pb new file mode 100644 index 0000000000..4f26c6ca66 --- /dev/null +++ b/c/Mf-pb @@ -0,0 +1,9 @@ +# Mf-pb + +# Override definitions in `Mf-pbhost` +m = pb +Cpu = PORTABLE_BYTECODE +mdsrc = pb.c +mdobj = pb.o + +include Mf-pbhost diff --git a/c/Mf-ppc32le b/c/Mf-ppc32le index 27d6b178c7..3591338995 100644 --- a/c/Mf-ppc32le +++ b/c/Mf-ppc32le @@ -13,14 +13,14 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = ppc32le -Cpu = PPC32 +m ?= ppc32le +Cpu ?= PPC32 -mdclib = -lm -ldl ${ncursesLib} -lrt -luuid -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} +mdclib = -lm -ldl ${ncursesLib} -lrt -luuid ${threadLibs} +C = ${CC} ${CPPFLAGS} -m32 ${warningFlags} ${optFlags} ${threadFlags} ${CFLAGS} o = o -mdsrc = ppc32.c -mdobj = ppc32.o +mdsrc ?= ppc32.c +mdobj ?= ppc32.o .SUFFIXES: .SUFFIXES: .c .o @@ -40,7 +40,7 @@ ${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} ../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) + (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ./configure) ../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) + (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} ${optFlags} -m32" ${MAKE} liblz4.a) diff --git a/c/Mf-ta6fb b/c/Mf-ta6fb index a7ced1b47f..b251569b37 100644 --- a/c/Mf-ta6fb +++ b/c/Mf-ta6fb @@ -1,47 +1,8 @@ # Mf-ta6fb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6fb -Cpu = X86_64 -mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) +include Mf-a6fb diff --git a/c/Mf-ta6le b/c/Mf-ta6le index 36943df18e..44a12cb046 100644 --- a/c/Mf-ta6le +++ b/c/Mf-ta6le @@ -1,46 +1,8 @@ # Mf-ta6le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6le -Cpu = X86_64 -mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid -C = ${CC} ${CPPFLAGS} -m64 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) +include Mf-a6le diff --git a/c/Mf-ta6nb b/c/Mf-ta6nb index 93266a86ff..75ead45e0f 100644 --- a/c/Mf-ta6nb +++ b/c/Mf-ta6nb @@ -1,48 +1,8 @@ # Mf-ta6nb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6nb -Cpu = X86_64 -mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include -mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -lpthread -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - paxctl +m ${Scheme} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) +include Mf-a6nb diff --git a/c/Mf-ta6nt b/c/Mf-ta6nt index c872906788..9e1fb593ab 100644 --- a/c/Mf-ta6nt +++ b/c/Mf-ta6nt @@ -1,62 +1,5 @@ # Mf-ta6nt -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6nt -Cpu = X86_64 -clib= -o = obj -mdobj=windows.$o -mdsrc=windows.c Makefile.$m cs.ico scheme.rc make.bat -mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* -cross=f - -include Mf-base - -${Scheme}${cross:f=}: make.bat - cmd.exe /c make.bat - cp ../bin/$m/scheme.exe ../bin/$m/petite.exe - cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb - -make.bat: vs.bat - echo '@echo off' > $@ - echo 'set MAKEFLAGS=' >> $@ - echo 'vs.bat amd64 && nmake /f Makefile.$m /nologo %*' >> $@ - chmod +x $@ - -# ------------------------------------------------------- -# For cross-compilation, triggered by setting cross=t o=o - -C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} - -${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid - -.c.$o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -../zlib/configure.log: - echo "all:" >> ../zlib/Makefile - echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile - touch ../zlib/configure.log - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a) +include Mf-a6nt diff --git a/c/Mf-ta6ob b/c/Mf-ta6ob index e52300c6c0..e973b66ff2 100644 --- a/c/Mf-ta6ob +++ b/c/Mf-ta6ob @@ -1,47 +1,8 @@ # Mf-ta6ob -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6ob -Cpu = X86_64 -mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) +include Mf-a6ob diff --git a/c/Mf-ta6osx b/c/Mf-ta6osx index 6499ac2522..2696b70f1e 100644 --- a/c/Mf-ta6osx +++ b/c/Mf-ta6osx @@ -1,46 +1,5 @@ # Mf-ta6osx -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6osx -Cpu = X86_64 -mdclib = -liconv -lm ${ncursesLib} -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -g -O2 -I/opt/X11/include/ ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) +include Mf-a6osx diff --git a/c/Mf-ta6s2 b/c/Mf-ta6s2 index 73c939bcd6..525fe5fa32 100644 --- a/c/Mf-ta6s2 +++ b/c/Mf-ta6s2 @@ -1,46 +1,8 @@ # Mf-ta6s2 -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6s2 -Cpu = X86_64 -mdclib = -lnsl -ldl -lm -lpthread ${cursesLib} -lrt -C = ${CC} ${CPPFLAGS} -m64 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_x86_64 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ./configure --64) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m64" ${MAKE} liblz4.a) +include Mf-a6s2 diff --git a/c/Mf-tarm32le b/c/Mf-tarm32le index c5960916df..6a9d00b639 100644 --- a/c/Mf-tarm32le +++ b/c/Mf-tarm32le @@ -1,46 +1,7 @@ -# Mf-arm32le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. +# Mf-tarm32le m = tarm32le -Cpu = ARMV6 -mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} -o = o -mdsrc = arm32le.c -mdobj = arm32le.o +threadLibs = -lpthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${MAKE} liblz4.a) +include Mf-arm32le diff --git a/c/Mf-tarm64le b/c/Mf-tarm64le index b68d887c95..790afe2134 100644 --- a/c/Mf-tarm64le +++ b/c/Mf-tarm64le @@ -1,46 +1,7 @@ -# Mf-arm64le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. +# Mf-tarm64le m = tarm64le -Cpu = AARCH64 -mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 ${CFLAGS} -o = o -mdsrc = arm32le.c -mdobj = arm32le.o +threadLibs = -lpthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${MAKE} liblz4.a) +include Mf-arm64le diff --git a/c/Mf-ti3fb b/c/Mf-ti3fb index 1dbc2fb0dd..b4e99bb6b5 100644 --- a/c/Mf-ti3fb +++ b/c/Mf-ti3fb @@ -1,47 +1,8 @@ # Mf-ti3fb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3fb -Cpu = I386 -mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) +include Mf-i3fb diff --git a/c/Mf-ti3le b/c/Mf-ti3le index 87fa03896a..44a2c9d499 100644 --- a/c/Mf-ti3le +++ b/c/Mf-ti3le @@ -1,46 +1,8 @@ # Mf-ti3le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3le -Cpu = I386 -mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid -C = ${CC} ${CPPFLAGS} -m32 -msse2 -Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) +include Mf-i3le diff --git a/c/Mf-ti3nb b/c/Mf-ti3nb index c33d7d983c..29fe5184ad 100644 --- a/c/Mf-ti3nb +++ b/c/Mf-ti3nb @@ -1,48 +1,8 @@ # Mf-ti3nb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3nb -Cpu = I386 -mdinclude = -I/usr/X11R7/include -I/usr/pkg/include -I/usr/pkg/include/ncurses -I/usr/X11R6/include -mdclib = /usr/lib/i18n/libiconv_std.a -lm /usr/pkg/lib/libncurses.a -lpthread -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -m elf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - paxctl +m ${Scheme} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) +include Mf-i3nb diff --git a/c/Mf-ti3nt b/c/Mf-ti3nt index 9ac4353547..4a04350802 100644 --- a/c/Mf-ti3nt +++ b/c/Mf-ti3nt @@ -1,62 +1,5 @@ # Mf-ti3nt -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3nt -Cpu = I386 -clib= -o = obj -mdobj=windows.$o -mdsrc=windows.c Makefile.$m cs.ico scheme.rc make.bat -mdclean=vs.bat make.bat scheme.res ../bin/$m/*.exp mtscheme.exe* mdscheme.exe* -cross=f - -include Mf-base - -${Scheme}${cross:f=}: make.bat - cmd.exe /c make.bat - cp ../bin/$m/scheme.exe ../bin/$m/petite.exe - cp ../bin/$m/scheme.pdb ../bin/$m/petite.pdb - -make.bat: vs.bat - echo '@echo off' > $@ - echo 'set MAKEFLAGS=' >> $@ - echo 'vs.bat x86 && nmake /f Makefile.$m /nologo %*' >> $@ - chmod +x $@ - -# ------------------------------------------------------- -# For cross-compilation, triggered by setting cross=t o=o - -C = ${CC} ${CPPFLAGS} -O2 ${CFLAGS} -D__MINGW_USE_VC2005_COMPAT - -${Scheme}${cross:t=}: ${Main} ${Kernel} ${KernelLinkDeps} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} -lshell32 -luser32 -lole32 -lrpcrt4 -luuid - -.c.$o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -../zlib/configure.log: - echo "all:" >> ../zlib/Makefile - echo ' $$(MAKE) -f win32/Makefile.gcc CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" RC="$(WINDRES)"' >> ../zlib/Makefile - touch ../zlib/configure.log - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; CC="$(CC)" CFLAGS="$(CFLAGS)" AR="$(AR)" RANLIB="$(RANLIB)" ${MAKE} liblz4.a) +include Mf-i3nt diff --git a/c/Mf-ti3ob b/c/Mf-ti3ob index 20aaf02156..494e937701 100644 --- a/c/Mf-ti3ob +++ b/c/Mf-ti3ob @@ -1,47 +1,8 @@ # Mf-ti3ob -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3ob -Cpu = I386 -mdinclude = -I/usr/local/include -I/usr/X11R6/include -mdclib = -L/usr/local/lib -liconv -lm ${ncursesLib} -lpthread -lossp-uuid -C = ${CC} ${CPPFLAGS} -Wpointer-arith -Werror -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} ${mdinclude} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -Wl,--export-dynamic -Wl,-zwxneeded -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) +include Mf-i3ob diff --git a/c/Mf-ti3osx b/c/Mf-ti3osx index 26a3fb2655..2f0c8d7c11 100644 --- a/c/Mf-ti3osx +++ b/c/Mf-ti3osx @@ -1,46 +1,5 @@ # Mf-ti3osx -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3osx -Cpu = I386 -mdclib = -liconv -lm ${ncursesLib} -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wall -Wextra -Wno-implicit-fallthrough -Werror -g -O2 -msse2 -I/opt/X11/include/ ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o - -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) +include Mf-i3osx diff --git a/c/Mf-ti3s2 b/c/Mf-ti3s2 index 407e25fbbc..0cbf376db6 100644 --- a/c/Mf-ti3s2 +++ b/c/Mf-ti3s2 @@ -1,46 +1,8 @@ # Mf-ti3s2 -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3s2 -Cpu = I386 -mdclib = -lnsl -ldl -lm -lpthread ${cursesLib} -lrt -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -O2 -D_REENTRANT ${CFLAGS} -o = o -mdsrc = i3le.c -mdobj = i3le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -DSOLARIS -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -melf_i386 -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) +include Mf-i3s2 diff --git a/c/Mf-tppc32le b/c/Mf-tppc32le index 2baf01ddf5..3182da0ac2 100644 --- a/c/Mf-tppc32le +++ b/c/Mf-tppc32le @@ -1,46 +1,8 @@ # Mf-tppc32le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = tppc32le -Cpu = PPC32 -mdclib = -lm -ldl ${ncursesLib} -lpthread -lrt -luuid -C = ${CC} ${CPPFLAGS} -m32 -Wpointer-arith -Wextra -Werror -Wno-implicit-fallthrough -O2 -D_REENTRANT -pthread ${CFLAGS} -o = o -mdsrc = ppc32le.c -mdobj = ppc32le.o +threadLibs = -lpthread +threadFlags = -D_REENTRANT -pthread -.SUFFIXES: -.SUFFIXES: .c .o - -.c.o: - $C -c -D${Cpu} -I${Include} ${zlibInc} ${LZ4Inc} $*.c - -include Mf-base - -${KernelO}: ${kernelobj} ${zlibDep} ${LZ4Dep} - ${LD} -r -X -o ${KernelO} ${kernelobj} ${zlibLib} ${LZ4Lib} - -${KernelLib}: ${kernelobj} - ${AR} ${ARFLAGS} ${KernelLib} ${kernelobj} - -${Scheme}: ${Kernel} ${KernelLinkDeps} ${Main} - $C -rdynamic -o ${Scheme} ${Main} ${Kernel} ${mdclib} ${KernelLinkLibs} ${LDFLAGS} - -../zlib/configure.log: - (cd ../zlib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ./configure) - -../lz4/lib/liblz4.a: ${LZ4Sources} - (cd ../lz4/lib; ${SetConfigEnv} CFLAGS="${CFLAGS} -m32" ${MAKE} liblz4.a) +include Mf-ppc32le diff --git a/c/alloc.c b/c/alloc.c index e6d25f40b8..833cb5abe7 100644 --- a/c/alloc.c +++ b/c/alloc.c @@ -153,7 +153,7 @@ ptr S_compute_bytes_allocated(xg, xs) ptr xg; ptr xs; { n += S_G.bytes_of_space[s][g]; /* add in bytes in active segments */ if (S_G.next_loc[s][g] != FIX(0)) - n += (char *)S_G.next_loc[s][g] - (char *)S_G.base_loc[s][g]; + n += (uptr)S_G.next_loc[s][g] - (uptr)S_G.base_loc[s][g]; } if (g == S_G.max_nonstatic_generation) g = static_generation; @@ -183,7 +183,7 @@ static void maybe_fire_collector() { bytes += S_G.bytes_of_space[s][0]; /* bytes in current block of segments */ if (S_G.next_loc[s][0] != FIX(0)) - bytes += (char *)S_G.next_loc[s][0] - (char *)S_G.base_loc[s][0]; + bytes += (uptr)S_G.next_loc[s][0] - (uptr)S_G.base_loc[s][0]; } /* arbitrary fudge factor to account for space we may not be using yet @@ -231,10 +231,10 @@ ptr S_find_more_room(s, g, n, old) ISPC s; IGEN g; iptr n; ptr old; { S_G.first_loc[s][g] = new; } else { /* increment bytes_allocated by the closed-off partial segment */ - S_G.bytes_of_space[s][g] += (char *)old - (char *)S_G.base_loc[s][g]; + S_G.bytes_of_space[s][g] += (uptr)old - (uptr)S_G.base_loc[s][g]; /* lay down an end-of-segment marker */ - *(ptr*)old = forward_marker; - *((ptr*)old + 1) = new; + *(ptr*)TO_VOIDP(old) = forward_marker; + *((ptr*)TO_VOIDP(old) + 1) = new; } /* base address of current block of segments to track amount of allocation */ @@ -307,7 +307,7 @@ FORCEINLINE void mark_segment_dirty(seginfo *si, IGEN from_g) { void S_dirty_set(ptr *loc, ptr x) { *loc = x; if (!Sfixnump(x)) { - seginfo *si = SegInfo(addr_get_segment(loc)); + seginfo *si = SegInfo(addr_get_segment(TO_PTR(loc))); if (si->use_marks) { /* GC must be in progress */ if (!IMMEDIATE(x)) { @@ -318,7 +318,7 @@ void S_dirty_set(ptr *loc, ptr x) { } else { IGEN from_g = si->generation; if (from_g != 0) { - si->dirty_bytes[((uptr)loc >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0; + si->dirty_bytes[((uptr)TO_PTR(loc) >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)] = 0; mark_segment_dirty(si, from_g); } } @@ -326,13 +326,13 @@ void S_dirty_set(ptr *loc, ptr x) { } /* scan remembered set from P to ENDP, transfering to dirty vector */ -void S_scan_dirty(ptr **p, ptr **endp) { +void S_scan_dirty(ptr *p, ptr *endp) { uptr this, last; last = 0; while (p < endp) { - ptr *loc = *p; + ptr loc = *p; /* whether building s directory or running UXLB code, the most common situations are that *loc is a fixnum, this == last, or loc is in generation 0. the generated code no longer adds elements @@ -369,7 +369,7 @@ void S_scan_remembered_set() { eap = (uptr)EAP(tc); real_eap = (uptr)REAL_EAP(tc); - S_scan_dirty((ptr **)eap, (ptr **)real_eap); + S_scan_dirty(TO_VOIDP(eap), TO_VOIDP(real_eap)); eap = real_eap; if (eap - ap > alloc_waste_maximum) { @@ -410,7 +410,7 @@ ptr S_get_more_room_help(ptr tc, uptr ap, uptr type, uptr size) { tc_mutex_acquire() - S_scan_dirty((ptr **)eap, (ptr **)real_eap); + S_scan_dirty(TO_VOIDP(eap), TO_VOIDP(real_eap)); eap = real_eap; if (eap - ap >= size) { @@ -461,15 +461,15 @@ void S_list_bits_set(p, bits) ptr p; iptr bits; { If a race loses bits, that's ok, as long as it's unlikely. */ if (!si->list_bits) { - ptr list_bits; + void *list_bits; if (si->generation == 0) { ptr tc = get_thread_context(); - thread_find_room(tc, typemod, ptr_align(segment_bitmap_bytes), list_bits); + thread_find_room_voidp(tc, ptr_align(segment_bitmap_bytes), list_bits); } else { tc_mutex_acquire() - find_room(space_data, si->generation, typemod, ptr_align(segment_bitmap_bytes), list_bits); + find_room_voidp(space_data, si->generation, ptr_align(segment_bitmap_bytes), list_bits); tc_mutex_release() } @@ -514,8 +514,8 @@ ptr S_ephemeron_cons_in(gen, car, cdr) IGEN gen; ptr car, cdr; { find_room(space_ephemeron, gen, type_pair, size_ephemeron, p); INITCAR(p) = car; INITCDR(p) = cdr; - EPHEMERONPREVREF(p) = NULL; - EPHEMERONNEXT(p) = NULL; + EPHEMERONPREVREF(p) = 0; + EPHEMERONNEXT(p) = 0; return p; } @@ -958,7 +958,7 @@ ptr S_code(tc, type, n) ptr tc; iptr type, n; { /* we record the code modification here, even though we haven't even started modifying the code yet, since we always create and fill the code object within a critical section. */ - S_record_code_mod(tc, (uptr)&CODEIT(p,0), (uptr)n); + S_record_code_mod(tc, (uptr)TO_PTR(&CODEIT(p,0)), (uptr)n); return p; } diff --git a/c/compress-io.c b/c/compress-io.c index 15eba871ac..adef75d468 100644 --- a/c/compress-io.c +++ b/c/compress-io.c @@ -472,9 +472,9 @@ static INT glzemit_lz4(lz4File_out *lz4, void *buffer, UINT count) { /* allocate one out_buffer (per thread) since we don't need one for each file. the buffer is freed by destroy_thread. */ - if ((cached_out_buffer = LZ4OUTBUFFER(tc)) == NULL || cached_out_buffer->size < lz4->out_buffer_size) { + if ((cached_out_buffer = TO_VOIDP(LZ4OUTBUFFER(tc))) == NULL || cached_out_buffer->size < lz4->out_buffer_size) { if (cached_out_buffer != NULL) free(cached_out_buffer); - if ((LZ4OUTBUFFER(tc) = cached_out_buffer = malloc(sizeof(sized_buffer) + lz4->out_buffer_size)) == NULL) return -1; + if ((LZ4OUTBUFFER(tc) = TO_PTR(cached_out_buffer = malloc(sizeof(sized_buffer) + lz4->out_buffer_size))) == 0) return -1; cached_out_buffer->size = lz4->out_buffer_size; } out_buffer = cached_out_buffer->buffer; diff --git a/c/externs.h b/c/externs.h index f52c4c4148..dfab0e02ab 100644 --- a/c/externs.h +++ b/c/externs.h @@ -67,7 +67,7 @@ extern ptr S_compute_bytes_allocated PROTO((ptr xg, ptr xs)); extern ptr S_bytes_finalized PROTO(()); extern ptr S_find_more_room PROTO((ISPC s, IGEN g, iptr n, ptr old)); extern void S_dirty_set PROTO((ptr *loc, ptr x)); -extern void S_scan_dirty PROTO((ptr **p, ptr **endp)); +extern void S_scan_dirty PROTO((ptr *p, ptr *endp)); extern void S_scan_remembered_set PROTO((void)); extern void S_get_more_room PROTO((void)); extern ptr S_get_more_room_help PROTO((ptr tc, uptr ap, uptr type, uptr size)); @@ -120,6 +120,9 @@ extern int S_fasl_intern_rtd(ptr *x); #ifdef X86_64 extern void x86_64_set_popcount_present PROTO((ptr code)); #endif +#ifdef PORTABLE_BYTECODE_BIGENDIAN +extern void S_swap_dounderflow_header_endian PROTO((ptr code)); +#endif /* vfasl.c */ extern ptr S_to_vfasl PROTO((ptr v)); @@ -230,14 +233,8 @@ extern void S_glzclearerr PROTO((glzFile fdfile)); extern INT S_gzxfile_fd PROTO((ptr x)); extern glzFile S_gzxfile_gzfile PROTO((ptr x)); extern ptr S_new_open_input_fd PROTO((const char *filename, IBOOL compressed)); -extern ptr S_new_open_output_fd PROTO(( - const char *filename, INT mode, - IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, - IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed)); -extern ptr S_new_open_input_output_fd PROTO(( - const char *filename, INT mode, - IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, - IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed)); +extern ptr S_new_open_output_fd PROTO((const char *filename, INT mode, INT options)); +extern ptr S_new_open_input_output_fd PROTO((const char *filename, INT mode, INT options)); extern ptr S_close_fd PROTO((ptr file, IBOOL gzflag)); extern ptr S_compress_input_fd PROTO((INT fd, I64 fp)); extern ptr S_compress_output_fd PROTO((INT fd)); @@ -414,6 +411,11 @@ extern void S_call_help PROTO((ptr tc, IBOOL singlep, IBOOL lock_ts)); extern void S_call_one_result PROTO((void)); extern void S_call_any_results PROTO((void)); +#ifdef PORTABLE_BYTECODE +/* pb.c */ +extern void S_pb_interp(ptr tc, void *bytecode); +#endif + #ifdef WIN32 /* windows.c */ extern INT S_getpagesize(void); diff --git a/c/fasl.c b/c/fasl.c index 78fdad23f1..e2b919cd43 100644 --- a/c/fasl.c +++ b/c/fasl.c @@ -232,6 +232,10 @@ static void faslin PROTO((ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f)); static void fasl_record PROTO((ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr size)); static IBOOL rtd_equiv PROTO((ptr x, ptr y)); static IBOOL equalp PROTO((ptr x, ptr y)); +#ifdef PORTABLE_BYTECODE +static void pb_set_abs PROTO((void *address, uptr item)); +static uptr pb_get_abs PROTO((void *address)); +#endif /* AARCH64 */ #ifdef ARMV6 static void arm32_set_abs PROTO((void *address, uptr item)); static uptr arm32_get_abs PROTO((void *address)); @@ -262,6 +266,9 @@ static U32 adjust_delay_inst PROTO((U32 delay_inst, U32 *old_call_addr, U32 *new static INT sparc64_set_lit_only PROTO((void *address, uptr item, I32 destreg)); static void sparc64_set_literal PROTO((void *address, uptr item)); #endif /* SPARC64 */ +#ifdef PORTABLE_BYTECODE_BIGENDIAN +static void swap_code_endian(octet *code, uptr len); +#endif static double s_nan; @@ -556,7 +563,7 @@ static ptr bv_fasl_entry(ptr tc, ptr bv, int ty, uptr offset, uptr len, unbufFas struct faslFileObj ffo; if (ty == fasl_type_vfasl) { - x = S_vfasl(bv, (ptr)0, offset, len); + x = S_vfasl(bv, NULL, offset, len); } else if (ty == fasl_type_fasl) { ffo.size = len; ffo.next = ffo.buf = &BVIT(bv, offset); @@ -1021,6 +1028,9 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { S_G.profile_counters = Scons(S_weak_cons(co, pinfos), S_G.profile_counters); } bytesin((octet *)&CODEIT(co, 0), n, f); +#ifdef PORTABLE_BYTECODE_BIGENDIAN + swap_code_endian((octet *)&CODEIT(co, 0), n); +#endif m = uptrin(f); CODERELOC(co) = reloc = S_relocation_table(m); RELOCCODE(reloc) = co; @@ -1095,37 +1105,46 @@ static void faslin(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f) { #define big 0 #define little 1 +#ifdef PORTABLE_BYTECODE +# ifdef PORTABLE_BYTECODE_BIGENDIAN +# define unknown big +# else +# define unknown little +# endif +#else +# define unknown 3 +#endif static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr size) { uptr n, addr; ptr p; UINT padty; n = uptrin(f); *x = p = S_record(size_record_inst(size)); faslin(tc, &RECORDINSTTYPE(p), t, pstrbuf, f); - addr = (uptr)&RECORDINSTIT(p, 0); + addr = (uptr)TO_PTR(&RECORDINSTIT(p, 0)); for (; n != 0; n -= 1) { padty = bytein(f); addr += padty >> 4; switch (padty & 0xf) { case fasl_fld_ptr: - faslin(tc, (ptr *)addr, t, pstrbuf, f); + faslin(tc, TO_VOIDP(addr), t, pstrbuf, f); addr += sizeof(ptr); break; case fasl_fld_u8: - *(U8 *)addr = (U8)bytein(f); + *(U8 *)TO_VOIDP(addr) = (U8)bytein(f); addr += 1; break; case fasl_fld_i16: - *(I16 *)addr = (I16)iptrin(f); + *(I16 *)TO_VOIDP(addr) = (I16)iptrin(f); addr += 2; break; case fasl_fld_i24: { iptr q = iptrin(f); #if (native_endianness == little) - *(U16 *)addr = (U16)q; - *(U8 *)(addr + 2) = (U8)(q >> 16); + *(U16 *)TO_VOIDP(addr) = (U16)q; + *(U8 *)TO_VOIDP(addr + 2) = (U8)(q >> 16); #elif (native_endianness == big) - *(U16 *)addr = (U16)(q >> 8); - *(U8 *)(addr + 2) = (U8)q; + *(U16 *)TO_VOIDP(addr) = (U16)(q >> 8); + *(U8 *)TO_VOIDP(addr + 2) = (U8)q; #else unexpected_endianness(); #endif @@ -1133,7 +1152,7 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr si break; } case fasl_fld_i32: - *(I32 *)addr = (I32)iptrin(f); + *(I32 *)TO_VOIDP(addr) = (I32)iptrin(f); addr += 4; break; case fasl_fld_i40: { @@ -1147,11 +1166,11 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr si unexpected_ptr_bits(); #endif #if (native_endianness == little) - *(U32 *)addr = (U32)q; - *(U8 *)(addr + 4) = (U8)(q >> 32); + *(U32 *)TO_VOIDP(addr) = (U32)q; + *(U8 *)TO_VOIDP(addr + 4) = (U8)(q >> 32); #elif (native_endianness == big) - *(U32 *)addr = (U32)(q >> 8); - *(U8 *)(addr + 4) = (U8)q; + *(U32 *)TO_VOIDP(addr) = (U32)(q >> 8); + *(U8 *)TO_VOIDP(addr + 4) = (U8)q; #else unexpected_endianness(); #endif @@ -1169,11 +1188,11 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr si unexpected_ptr_bits(); #endif #if (native_endianness == little) - *(U32 *)addr = (U32)q; - *(U16 *)(addr + 4) = (U16)(q >> 32); + *(U32 *)TO_VOIDP(addr) = (U32)q; + *(U16 *)TO_VOIDP(addr + 4) = (U16)(q >> 32); #elif (native_endianness == big) - *(U32 *)addr = (U32)(q >> 16); - *(U16 *)(addr + 4) = (U16)q; + *(U32 *)TO_VOIDP(addr) = (U32)(q >> 16); + *(U16 *)TO_VOIDP(addr + 4) = (U16)q; #else unexpected_endianness(); #endif @@ -1191,12 +1210,12 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr si unexpected_ptr_bits(); #endif #if (native_endianness == little) - *(U32 *)addr = (U32)q; - *(U16 *)(addr + 4) = (U16)(q >> 32); - *(U8 *)(addr + 6) = (U8)(q >> 48); + *(U32 *)TO_VOIDP(addr) = (U32)q; + *(U16 *)TO_VOIDP(addr + 4) = (U16)(q >> 32); + *(U8 *)TO_VOIDP(addr + 6) = (U8)(q >> 48); #elif (native_endianness == big) - *(U32 *)addr = (U32)(q >> 24); - *(U32 *)(addr + 3) = (U32)q; + *(U32 *)TO_VOIDP(addr) = (U32)(q >> 24); + *(U32 *)TO_VOIDP(addr + 3) = (U32)q; #else unexpected_endianness(); #endif @@ -1213,16 +1232,16 @@ static void fasl_record(ptr tc, ptr *x, ptr t, ptr *pstrbuf, faslFile f, uptr si #else unexpected_ptr_bits(); #endif - *(I64 *)addr = q; + *(I64 *)TO_VOIDP(addr) = q; addr += 8; break; } case fasl_fld_single: - *(float *)addr = (float)singlein(f); + *(float *)TO_VOIDP(addr) = (float)singlein(f); addr += sizeof(float); break; case fasl_fld_double: - *(double *)addr = (double)doublein(f); + *(double *)TO_VOIDP(addr) = (double)doublein(f); addr += sizeof(double); break; default: @@ -1318,12 +1337,18 @@ INT pax_encode21(INT n) void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; ptr p, x; { void *address; uptr item; - address = (void *)((uptr)p + n); + address = TO_VOIDP((uptr)p + n); item = (uptr)x + o; switch (typ) { case reloc_abs: *(uptr *)address = item; break; +#ifdef PORTABLE_BYTECODE + case reloc_pb_abs: + case reloc_pb_proc: + pb_set_abs(address, item); + break; +#endif /* AARCH64 */ #ifdef ARMV6 case reloc_arm32_abs: arm32_set_abs(address, item); @@ -1406,11 +1431,17 @@ void S_set_code_obj(who, typ, p, n, x, o) char *who; IFASLCODE typ; iptr n, o; p ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; { void *address; uptr item; - address = (void *)((uptr)p + n); + address = TO_VOIDP((uptr)p + n); switch (typ) { case reloc_abs: item = *(uptr *)address; break; +#ifdef PORTABLE_BYTECODE + case reloc_pb_abs: + case reloc_pb_proc: + item = pb_get_abs(address); + break; +#endif /* AARCH64 */ #ifdef ARMV6 case reloc_arm32_abs: item = arm32_get_abs(address); @@ -1479,6 +1510,33 @@ ptr S_get_code_obj(typ, p, n, o) IFASLCODE typ; iptr n, o; ptr p; { } +#ifdef PORTABLE_BYTECODE + +/* Address pieces in a movz,movk,movk,movk sequence are upper 16 bits */ +#define ADDRESS_BITS_SHIFT 16 +#define ADDRESS_BITS_MASK ((U32)0xffff0000) + +static void pb_set_abs(void *address, uptr item) { + ((U32 *)address)[0] = ((((U32 *)address)[0] & ~ADDRESS_BITS_MASK) | ((item & 0xFFFF) << ADDRESS_BITS_SHIFT)); + ((U32 *)address)[1] = ((((U32 *)address)[1] & ~ADDRESS_BITS_MASK) | (((item >> 16) & 0xFFFF) << ADDRESS_BITS_SHIFT)); +#if ptr_bytes == 8 + ((U32 *)address)[2] = ((((U32 *)address)[2] & ~ADDRESS_BITS_MASK) | (((item >> 32) & 0xFFFF) << ADDRESS_BITS_SHIFT)); + ((U32 *)address)[3] = ((((U32 *)address)[3] & ~ADDRESS_BITS_MASK) | (((item >> 48) & 0xFFFF) << ADDRESS_BITS_SHIFT)); +#endif +} + +static uptr pb_get_abs(void *address) { + return ((uptr)((((U32 *)address)[0] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) + | ((uptr)((((U32 *)address)[1] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 16) +#if ptr_bytes == 8 + | ((uptr)((((U32 *)address)[2] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 32) + | ((uptr)((((U32 *)address)[3] & ADDRESS_BITS_MASK) >> ADDRESS_BITS_SHIFT) << 48) +#endif + ); +} + +#endif /* AARCH64 */ + #ifdef ARMV6 static void arm32_set_abs(void *address, uptr item) { /* code generator produces ldrlit destreg, 0; brai 0; long 0 */ @@ -1852,3 +1910,81 @@ static void sparc64_set_literal(address, item) void *address; uptr item; { sparc64_set_lit_only(address, item, destreg); } #endif /* SPARC64 */ + +#ifdef PORTABLE_BYTECODE_BIGENDIAN +static void swap_code_endian(octet *code, uptr len) +{ + octet *next_rpheader = NULL; + uptr header_size = 0; + + while (len > 0) { + if (code == next_rpheader) { + /* swap 8-byte segments while we're in the header */ + while (header_size > 0) { + octet a = code[0]; + octet b = code[1]; + octet c = code[2]; + octet d = code[3]; + octet e = code[4]; + octet f = code[5]; + octet g = code[6]; + octet h = code[7]; + code[0] = h; + code[1] = g; + code[2] = f; + code[3] = e; + code[4] = d; + code[5] = c; + code[6] = b; + code[7] = a; + + code += 8; + len -= 8; + header_size -= 8; + } + } else { + /* swap a 4-byte instruction */ + octet a = code[0]; + octet b = code[1]; + octet c = code[2]; + octet d = code[3]; + code[0] = d; + code[1] = c; + code[2] = b; + code[3] = a; + + if (a == pb_adr) { + /* after a few more instructions, we'll hit + a header where 64-bit values needs to be + swapped, instead of 32-bit values */ + uptr delta = ((uptr)d << 16) + c; + octet *after_rpheader = code + 4 + delta; + + if (after_rpheader[-8] & 0x1) + header_size = size_rp_compact_header; + else + header_size = size_rp_header; + + next_rpheader = after_rpheader - header_size; + } + + code += 4; + len -= 4; + } + } +} + +void S_swap_dounderflow_header_endian(ptr co) +{ + /* The `dounderflow` library entry starts with a header, so + it does not have a `pb_adr` instruction before. We need + to finish swapping the header's `ptr`-sized values, but + the mv-return address is already linked, so the only + thing to fix turns out to be the first `ptr`. */ + uint32_t *code = (uint32_t *)&CODEIT(co, 0); + uint32_t a = code[0]; + uint32_t b = code[1]; + code[0] = b; + code[1] = a; +} +#endif diff --git a/c/foreign.c b/c/foreign.c index 5c1c2abb3d..590f92427e 100644 --- a/c/foreign.c +++ b/c/foreign.c @@ -23,8 +23,8 @@ /* we can now return arbitrary values (aligned or not) * since the garbage collector ignores addresses outside of the heap * or within foreign segments */ -#define ptr_to_addr(p) ((void *)p) -#define addr_to_ptr(a) ((ptr)a) +#define ptr_to_addr(p) TO_VOIDP(p) +#define addr_to_ptr(a) TO_PTR(a) /* buckets should be prime */ #define buckets 457 @@ -52,7 +52,9 @@ /* locally defined functions */ static iptr symhash PROTO((const char *s)); static ptr lookup_static PROTO((const char *s)); +#ifdef LOAD_SHARED_OBJECT static ptr lookup_dynamic PROTO((const char *s, ptr tbl)); +#endif static ptr lookup PROTO((const char *s)); static ptr remove_foreign_entry PROTO((const char *s)); static void *lookup_foreign_entry PROTO((const char *s)); @@ -129,10 +131,9 @@ static ptr lookup_dynamic(s, tbl) const char *s; ptr tbl; { static ptr lookup(s) const char *s; { iptr b; ptr p; - -#ifdef LOOKUP_DYNAMIC ptr x; +#ifdef LOOKUP_DYNAMIC x = lookup_dynamic(s, S_foreign_dynamic); if (x == addr_to_ptr(0)) #endif /* LOOKUP_DYNAMIC */ diff --git a/c/gc.c b/c/gc.c index 3a627f8a21..9250ebcde3 100644 --- a/c/gc.c +++ b/c/gc.c @@ -266,7 +266,7 @@ uptr list_length(ptr ls) { #endif #define init_mask(dest, tg, init) { \ - find_room(space_data, tg, typemod, ptr_align(segment_bitmap_bytes), dest); \ + find_room_voidp(space_data, tg, ptr_align(segment_bitmap_bytes), dest); \ memset(dest, init, segment_bitmap_bytes); \ } @@ -291,7 +291,7 @@ static int flonum_is_forwarded_p(ptr p, seginfo *si) { return si->forwarded_flonums[segment_bitmap_byte(p)] & segment_bitmap_bit(p); } -# define FLONUM_FWDADDRESS(p) *(ptr*)(UNTYPE(p, type_flonum)) +# define FLONUM_FWDADDRESS(p) *(ptr*)TO_VOIDP(UNTYPE(p, type_flonum)) # define FORWARDEDP(p, si) ((TYPEBITS(p) == type_flonum) ? flonum_is_forwarded_p(p, si) : (FWDMARKER(p) == forward_marker)) # define GET_FWDADDRESS(p) ((TYPEBITS(p) == type_flonum) ? FLONUM_FWDADDRESS(p) : FWDADDRESS(p)) @@ -380,11 +380,11 @@ FORCEINLINE void check_triggers(seginfo *si) { if (si->has_triggers) { if (si->trigger_ephemerons) { add_trigger_ephemerons_to_pending(si->trigger_ephemerons); - si->trigger_ephemerons = NULL; + si->trigger_ephemerons = 0; } if (si->trigger_guardians) { add_trigger_guardians_to_recheck(si->trigger_guardians); - si->trigger_guardians = NULL; + si->trigger_guardians = 0; } si->has_triggers = 0; } @@ -461,7 +461,7 @@ static ptr copy_stack(old, length, clength) ptr old; iptr *length, clength; { find_room(space_data, target_generation, typemod, n, new); n = ptr_align(clength); /* warning: stack may have been left non-double-aligned by split_and_resize */ - memcpy_aligned(new, old, n); + memcpy_aligned(TO_VOIDP(new), TO_VOIDP(old), n); /* also returning possibly updated value in *length */ return new; @@ -531,7 +531,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { for (ls = S_threads; ls != Snil; ls = Scdr(ls)) { ptr tc = (ptr)THREADTC(Scar(ls)); - S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc)); + S_scan_dirty(TO_VOIDP(EAP(tc)), TO_VOIDP(REAL_EAP(tc))); EAP(tc) = REAL_EAP(tc) = AP(tc) = (ptr)0; } @@ -648,7 +648,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { iptr i; count_roots_len = list_length(count_roots_ls); - find_room(space_data, 0, typemod, ptr_align(count_roots_len*sizeof(count_root_t)), count_roots); + find_room_voidp(space_data, 0, ptr_align(count_roots_len*sizeof(count_root_t)), count_roots); for (ls = count_roots_ls, i = 0; ls != Snil; ls = Scdr(ls), i++) { ptr p = Scar(ls); @@ -678,7 +678,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { #ifdef ENABLE_OBJECT_COUNTS /* sweep count_roots in order and accumulate counts */ if (count_roots_len > 0) { - ptr prev = NULL; uptr prev_total = total_size_so_far(); + ptr prev = 0; uptr prev_total = total_size_so_far(); iptr i; # ifdef ENABLE_MEASURE @@ -717,7 +717,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { total = total_size_so_far(); p = S_cons_in(space_new, 0, FIX(total-prev_total), Snil); - if (prev != NULL) + if (prev != 0) Scdr(prev) = p; else count_roots_counts = p; @@ -800,13 +800,13 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { blnext = bl->cdr; b = bl->car; /* mark this bucket old for the rebuilding loop */ - b->next = (bucket *)((uptr)b->next | 1); + b->next = TO_VOIDP((uptr)TO_PTR(b->next) | 1); sym = b->sym; idx = UNFIX(SYMHASH(sym)) % S_G.oblist_length; oblist_cell = &S_G.oblist[idx]; - if (!((uptr)*oblist_cell & 1)) { + if (!((uptr)TO_PTR(*oblist_cell) & 1)) { /* mark this bucket in the set */ - *oblist_cell = (bucket *)((uptr)*oblist_cell | 1); + *oblist_cell = TO_VOIDP((uptr)TO_PTR(*oblist_cell) | 1); /* repurpose the bucket list element for the list of buckets to rebuild later */ /* idiot_checks verifies these have the same size */ bpl = (bucket_pointer_list *)bl; @@ -899,7 +899,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { rep = GUARDIANOBJ(ls); if (FWDMARKER(rep) == forward_marker) rep = FWDADDRESS(rep); /* Caution: Building in assumption about shape of an ftype pointer */ - addr = RECORDINSTIT(rep, 0); + addr = TO_VOIDP(RECORDINSTIT(rep, 0)); LOCKED_DECR(addr, b); if (!b) continue; } @@ -1072,12 +1072,12 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { bl = tg == static_generation ? NULL : S_G.buckets_of_generation[tg]; for (bpl = buckets_to_rebuild; bpl != NULL; bpl = bpl->cdr) { pb = bpl->car; - for (b = (bucket *)((uptr)*pb - 1); b != NULL && ((uptr)(b->next) & 1); b = bnext) { - bnext = (bucket *)((uptr)(b->next) - 1); + for (b = TO_VOIDP((uptr)TO_PTR(*pb) - 1); b != NULL && ((uptr)TO_PTR(b->next) & 1); b = bnext) { + bnext = TO_VOIDP((uptr)TO_PTR(b->next) - 1); sym = b->sym; si = SegInfo(ptr_get_segment(sym)); if (marked(si, sym) || (FWDMARKER(sym) == forward_marker && ((sym = FWDADDRESS(sym)) || 1))) { - find_room(space_data, tg, typemod, sizeof(bucket), b); + find_room_voidp(space_data, tg, ptr_align(sizeof(bucket)), b); #ifdef ENABLE_OBJECT_COUNTS S_G.countof[tg][countof_oblist] += 1; S_G.bytesof[tg][countof_oblist] += sizeof(bucket); @@ -1087,7 +1087,7 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { pb = &b->next; if (tg != static_generation) { blnext = bl; - find_room(space_data, tg, typemod, sizeof(bucket_list), bl); + find_room_voidp(space_data, tg, ptr_align(sizeof(bucket_list)), bl); #ifdef ENABLE_OBJECT_COUNTS S_G.countof[tg][countof_oblist] += 1; S_G.bytesof[tg][countof_oblist] += sizeof(bucket_list); @@ -1172,9 +1172,9 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { si->next = S_G.occupied_segments[s][tg]; S_G.occupied_segments[s][tg] = si; S_G.bytes_of_space[s][tg] += si->marked_count; - si->trigger_guardians = NULL; + si->trigger_guardians = 0; #ifdef PRESERVE_FLONUM_EQ - si->forwarded_flonums = NULL; + si->forwarded_flonums = 0; #endif } else { chunkinfo *chunk = si->chunk; @@ -1278,15 +1278,15 @@ ptr GCENTRY(ptr tc, IGEN mcg, IGEN tg, ptr count_roots_ls) { slp = &sweep_loc[s];\ nlp = &S_G.next_loc[s][g];\ if (*slp == 0) *slp = S_G.first_loc[s][g];\ - pp = (ptr *)*slp;\ - while (pp != (nl = (ptr *)*nlp))\ + pp = TO_VOIDP(*slp);\ + while (pp != (nl = TO_VOIDP(*nlp)))\ do\ if ((p = *pp) == forward_marker)\ - pp = (ptr *)*(pp + 1);\ + pp = TO_VOIDP(*(pp + 1)); \ else\ body\ while (pp != nl);\ - *slp = (ptr)pp; + *slp = TO_PTR(pp); static void resweep_weak_pairs(g, oldweakspacesegments) IGEN g; seginfo *oldweakspacesegments; { ptr *slp, *nlp; ptr *pp, p, *nl; @@ -1307,7 +1307,7 @@ static void resweep_weak_pairs(g, oldweakspacesegments) IGEN g; seginfo *oldweak int mask = si->marked_mask[i]; if (mask != 0) { /* Assuming 4 pairs per 8 words */ - pp = (ptr *)build_ptr(si->number, (i << (log2_ptr_bytes+3))); + pp = TO_VOIDP(build_ptr(si->number, (i << (log2_ptr_bytes+3)))); if (mask & 0x1) forward_or_bwp(pp, *pp); pp += 2; @@ -1346,7 +1346,7 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { sweep_from_stack(tc); sweep_space(space_impure, { - SET_BACKREFERENCE(TYPE((ptr)pp, type_pair)) /* only pairs put here in backreference mode */ + SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)) /* only pairs put here in backreference mode */ relocate_help(pp, p) p = *(pp += 1); relocate_help(pp, p) @@ -1355,19 +1355,19 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { SET_BACKREFERENCE(Sfalse) sweep_space(space_symbol, { - p = TYPE((ptr)pp, type_symbol); + p = TYPE(TO_PTR(pp), type_symbol); sweep_symbol(p); pp += size_symbol / sizeof(ptr); }) sweep_space(space_port, { - p = TYPE((ptr)pp, type_typed_object); + p = TYPE(TO_PTR(pp), type_typed_object); sweep_port(p); pp += size_port / sizeof(ptr); }) sweep_space(space_weakpair, { - SET_BACKREFERENCE(TYPE((ptr)pp, type_pair)) + SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)) p = *(pp += 1); relocate_help(pp, p) pp += 1; @@ -1375,13 +1375,13 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { SET_BACKREFERENCE(Sfalse) sweep_space(space_ephemeron, { - p = TYPE((ptr)pp, type_pair); + p = TYPE(TO_PTR(pp), type_pair); add_ephemeron_to_pending(p); pp += size_ephemeron / sizeof(ptr); }) sweep_space(space_pure, { - SET_BACKREFERENCE(TYPE((ptr)pp, type_pair)) /* only pairs put here in backreference mode */ + SET_BACKREFERENCE(TYPE(TO_PTR(pp), type_pair)) /* only pairs put here in backreference mode */ relocate_help(pp, p) p = *(pp += 1); relocate_help(pp, p) @@ -1390,40 +1390,40 @@ static void sweep_generation(tc, g) ptr tc; IGEN g; { SET_BACKREFERENCE(Sfalse) sweep_space(space_continuation, { - p = TYPE((ptr)pp, type_closure); + p = TYPE(TO_PTR(pp), type_closure); sweep_continuation(p); pp += size_continuation / sizeof(ptr); }) sweep_space(space_pure_typed_object, { - p = TYPE((ptr)pp, type_typed_object); - pp = (ptr *)((uptr)pp + sweep_typed_object(tc, p)); + p = TYPE(TO_PTR(pp), type_typed_object); + pp = TO_VOIDP(((uptr)TO_PTR(pp) + sweep_typed_object(tc, p))); }) sweep_space(space_code, { - p = TYPE((ptr)pp, type_typed_object); + p = TYPE(TO_PTR(pp), type_typed_object); sweep_code_object(tc, p); pp += size_code(CODELEN(p)) / sizeof(ptr); }) sweep_space(space_impure_record, { - p = TYPE((ptr)pp, type_typed_object); + p = TYPE(TO_PTR(pp), type_typed_object); sweep_record(p); - pp = (ptr *)((iptr)pp + + pp = TO_VOIDP((iptr)TO_PTR(pp) + size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))))); }) /* space used only as needed for backreferences: */ sweep_space(space_impure_typed_object, { - p = TYPE((ptr)pp, type_typed_object); - pp = (ptr *)((uptr)pp + sweep_typed_object(tc, p)); + p = TYPE(TO_PTR(pp), type_typed_object); + pp = TO_VOIDP((uptr)TO_PTR(pp) + sweep_typed_object(tc, p)); }) /* space used only as needed for backreferences: */ sweep_space(space_closure, { - p = TYPE((ptr)pp, type_closure); + p = TYPE(TO_PTR(pp), type_closure); sweep(tc, p); - pp = (ptr *)((uptr)pp + size_object(p)); + pp = TO_VOIDP((uptr)TO_PTR(pp) + size_object(p)); }) /* don't sweep from space_count_pure or space_count_impure */ @@ -1443,10 +1443,10 @@ void enlarge_sweep_stack() { ptr new_sweep_stack; find_room(space_data, 0, typemod, ptr_align(new_sz), new_sweep_stack); if (sz != 0) - memcpy(new_sweep_stack, sweep_stack_start, sz); - sweep_stack_start = (ptr *)new_sweep_stack; - sweep_stack_limit = (ptr *)((uptr)new_sweep_stack + new_sz); - sweep_stack = (ptr *)((uptr)new_sweep_stack + sz); + memcpy(TO_VOIDP(new_sweep_stack), TO_VOIDP(sweep_stack_start), sz); + sweep_stack_start = TO_VOIDP(new_sweep_stack); + sweep_stack_limit = TO_VOIDP((uptr)new_sweep_stack + new_sz); + sweep_stack = TO_VOIDP((uptr)new_sweep_stack + sz); } void sweep_from_stack(tc) ptr tc; { @@ -1538,12 +1538,12 @@ static void sweep_dirty(void) { } min_youngest = 0xff; - nl = from_g == tg ? (ptr *)orig_next_loc[s] : (ptr *)S_G.next_loc[s][from_g]; - ppend = build_ptr(seg, 0); + nl = from_g == tg ? TO_VOIDP(orig_next_loc[s]) : TO_VOIDP(S_G.next_loc[s][from_g]); + ppend = TO_VOIDP(build_ptr(seg, 0)); if (s == space_weakpair) { weakseginfo *next = weaksegments_to_resweep; - find_room(space_data, 0, typemod, sizeof(weakseginfo), weaksegments_to_resweep); + find_room_voidp(space_data, 0, ptr_align(sizeof(weakseginfo)), weaksegments_to_resweep); weaksegments_to_resweep->si = dirty_si; weaksegments_to_resweep->next = next; } @@ -1573,7 +1573,7 @@ static void sweep_dirty(void) { || (s == space_closure)) { while (pp < ppend && *pp != forward_marker) { /* handle two pointers at a time */ - if (!dirty_si->marked_mask || marked(dirty_si, pp)) { + if (!dirty_si->marked_mask || marked(dirty_si, TO_PTR(pp))) { relocate_dirty(pp,tg,youngest) pp += 1; relocate_dirty(pp,tg,youngest) @@ -1587,13 +1587,13 @@ static void sweep_dirty(void) { segments begins at the start of a segment, and symbols are much smaller (we assume) than the segment size. */ - pp = (ptr *)build_ptr(seg,0) + - ((pp - (ptr *)build_ptr(seg,0)) / + pp = (ptr *)TO_VOIDP(build_ptr(seg,0)) + + ((pp - (ptr *)TO_VOIDP(build_ptr(seg,0))) / (size_symbol / sizeof(ptr))) * (size_symbol / sizeof(ptr)); while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a symbol. no harm. */ - ptr p = TYPE((ptr)pp, type_symbol); + ptr p = TYPE(TO_PTR(pp), type_symbol); if (!dirty_si->marked_mask || marked(dirty_si, p)) youngest = sweep_dirty_symbol(p, tg, youngest); @@ -1606,13 +1606,13 @@ static void sweep_dirty(void) { segments begins at the start of a segment, and ports are much smaller (we assume) than the segment size. */ - pp = (ptr *)build_ptr(seg,0) + - ((pp - (ptr *)build_ptr(seg,0)) / + pp = (ptr *)TO_VOIDP(build_ptr(seg,0)) + + ((pp - (ptr *)TO_VOIDP(build_ptr(seg,0))) / (size_port / sizeof(ptr))) * (size_port / sizeof(ptr)); while (pp < ppend && *pp != forward_marker) { /* might overshoot card by part of a port. no harm. */ - ptr p = TYPE((ptr)pp, type_typed_object); + ptr p = TYPE(TO_PTR(pp), type_typed_object); if (!dirty_si->marked_mask || marked(dirty_si, p)) youngest = sweep_dirty_port(p, tg, youngest); @@ -1624,8 +1624,8 @@ static void sweep_dirty(void) { if (dirty_si->marked_mask) { /* To get to the start of a record, move backward as long as bytes are marked and segment space+generation+marked is the same. */ - uptr byte = segment_bitmap_byte(pp); - uptr bit = segment_bitmap_bit(pp); + uptr byte = segment_bitmap_byte(TO_PTR(pp)); + uptr bit = segment_bitmap_bit(TO_PTR(pp)); uptr at_seg = seg; seginfo *si = dirty_si; @@ -1692,7 +1692,7 @@ static void sweep_dirty(void) { p = TYPE(p, type_typed_object); /* now sweep, but watch out for unmarked holes in the dirty region */ - while ((ptr *)UNTYPE(p, type_typed_object) < ppend) { + while ((ptr *)TO_VOIDP(UNTYPE(p, type_typed_object)) < ppend) { seginfo *si = SegInfo(ptr_get_segment(p)); if (!marked(si, p)) { /* skip unmarked words */ @@ -1736,14 +1736,14 @@ static void sweep_dirty(void) { } /* now find first within dirty area */ - while ((ptr *)UNTYPE(pnext, type_typed_object) <= pp) { + while ((ptr *)TO_VOIDP(UNTYPE(pnext, type_typed_object)) <= pp) { p = pnext; pnext = (ptr)((iptr)p + size_record_inst(UNFIX(RECORDDESCSIZE(RECORDINSTTYPE(p))))); } /* now sweep */ - while ((ptr *)UNTYPE(p, type_typed_object) < ppend) { + while ((ptr *)TO_VOIDP(UNTYPE(p, type_typed_object)) < ppend) { /* quit on end of segment */ if (FWDMARKER(p) == forward_marker) break; @@ -1756,7 +1756,7 @@ static void sweep_dirty(void) { } else if (s == space_weakpair) { while (pp < ppend && *pp != forward_marker) { /* skip car field and handle cdr field */ - if (!dirty_si->marked_mask || marked(dirty_si, pp)) { + if (!dirty_si->marked_mask || marked(dirty_si, TO_PTR(pp))) { pp += 1; relocate_dirty(pp, tg, youngest) pp += 1; @@ -1765,7 +1765,7 @@ static void sweep_dirty(void) { } } else if (s == space_ephemeron) { while (pp < ppend && *pp != forward_marker) { - ptr p = TYPE((ptr)pp, type_pair); + ptr p = TYPE(TO_PTR(pp), type_pair); if (!dirty_si->marked_mask || marked(dirty_si, p)) youngest = check_dirty_ephemeron(p, tg, youngest); pp += size_ephemeron / sizeof(ptr); @@ -1809,8 +1809,8 @@ static void resweep_dirty_weak_pairs() { for (ls = weaksegments_to_resweep; ls != NULL; ls = ls->next) { seginfo *dirty_si = ls->si; from_g = dirty_si->generation; - nl = from_g == tg ? (ptr *)orig_next_loc[space_weakpair] : (ptr *)S_G.next_loc[space_weakpair][from_g]; - ppend = build_ptr(dirty_si->number, 0); + nl = from_g == tg ? TO_VOIDP(orig_next_loc[space_weakpair]) : TO_VOIDP(S_G.next_loc[space_weakpair][from_g]); + ppend = TO_VOIDP(build_ptr(dirty_si->number, 0)); min_youngest = 0xff; d = 0; while (d < cards_per_segment) { @@ -1876,7 +1876,7 @@ static void add_pending_guardian(ptr gdn, ptr tconc) static void add_trigger_guardians_to_recheck(ptr ls) { ptr last = ls, next = GUARDIANNEXT(ls); - while (next != NULL) { + while (next != 0) { last = next; next = GUARDIANNEXT(next); } @@ -1884,30 +1884,30 @@ static void add_trigger_guardians_to_recheck(ptr ls) recheck_guardians_ls = ls; } -static ptr pending_ephemerons = NULL; +static ptr pending_ephemerons = 0; /* Ephemerons that we haven't looked at, chained through `next`. */ static void ephemeron_remove(ptr pe) { ptr next = EPHEMERONNEXT(pe); - *((ptr *)EPHEMERONPREVREF(pe)) = next; + *((ptr *)TO_VOIDP(EPHEMERONPREVREF(pe))) = next; if (next) EPHEMERONPREVREF(next) = EPHEMERONPREVREF(pe); - EPHEMERONPREVREF(pe) = NULL; - EPHEMERONNEXT(pe) = NULL; + EPHEMERONPREVREF(pe) = 0; + EPHEMERONNEXT(pe) = 0; } static void ephemeron_add(ptr *first, ptr pe) { ptr last_pe = pe, next_pe = EPHEMERONNEXT(pe), next; - while (next_pe != NULL) { + while (next_pe != 0) { last_pe = next_pe; next_pe = EPHEMERONNEXT(next_pe); } next = *first; *first = pe; - EPHEMERONPREVREF(pe) = (ptr)first; + EPHEMERONPREVREF(pe) = TO_PTR(first); EPHEMERONNEXT(last_pe) = next; if (next) - EPHEMERONPREVREF(next) = &EPHEMERONNEXT(last_pe); + EPHEMERONPREVREF(next) = TO_PTR(&EPHEMERONNEXT(last_pe)); } static void add_ephemeron_to_pending(ptr pe) { @@ -1929,8 +1929,8 @@ static void check_ephemeron(ptr pe) { seginfo *si; PUSH_BACKREFERENCE(pe); - EPHEMERONNEXT(pe) = NULL; - EPHEMERONPREVREF(pe) = NULL; + EPHEMERONNEXT(pe) = 0; + EPHEMERONPREVREF(pe) = 0; p = Scar(pe); if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL && si->old_space) { @@ -1955,8 +1955,8 @@ static void check_pending_ephemerons() { ptr pe, next_pe; pe = pending_ephemerons; - pending_ephemerons = NULL; - while (pe != NULL) { + pending_ephemerons = 0; + while (pe != 0) { next_pe = EPHEMERONNEXT(pe); check_ephemeron(pe); pe = next_pe; @@ -2013,20 +2013,20 @@ static int check_dirty_ephemeron(ptr pe, int tg, int youngest) { static void finish_pending_ephemerons(seginfo *si) { /* Any ephemeron still in a trigger list is an ephemeron whose key was not reached. */ - if (pending_ephemerons != NULL) + if (pending_ephemerons != 0) S_error_abort("clear_trigger_ephemerons(gc): non-empty pending list"); for (; si != NULL; si = si->next) { if (si->trigger_ephemerons) { ptr pe, next_pe; - for (pe = si->trigger_ephemerons; pe != NULL; pe = next_pe) { + for (pe = si->trigger_ephemerons; pe != 0; pe = next_pe) { INITCAR(pe) = Sbwp_object; INITCDR(pe) = Sbwp_object; next_pe = EPHEMERONNEXT(pe); - EPHEMERONPREVREF(pe) = NULL; - EPHEMERONNEXT(pe) = NULL; + EPHEMERONPREVREF(pe) = 0; + EPHEMERONNEXT(pe) = 0; } - si->trigger_ephemerons = NULL; + si->trigger_ephemerons = 0; } } } @@ -2058,7 +2058,7 @@ static uptr target_generation_space_so_far() { for (s = 0; s <= max_real_space; s++) { sz += S_G.bytes_of_space[s][g]; if (S_G.next_loc[s][g] != FIX(0)) - sz += (char *)S_G.next_loc[s][g] - (char *)S_G.base_loc[s][g]; + sz += (uptr)S_G.next_loc[s][g] - (uptr)S_G.base_loc[s][g]; } return sz; @@ -2080,16 +2080,16 @@ void copy_and_clear_list_bits(seginfo *oldspacesegments, IGEN tg) { /* Besides marking or copying `si->list_bits`, clear bits where there's no corresponding mark bit, so we don't try to check forwarding in a future GC */ - seginfo *bits_si = SegInfo(ptr_get_segment((ptr)si->list_bits)); + seginfo *bits_si = SegInfo(ptr_get_segment(TO_PTR(si->list_bits))); if (bits_si->old_space) { if (bits_si->use_marks) { if (!bits_si->marked_mask) init_mask(bits_si->marked_mask, tg, 0); - bits_si->marked_mask[segment_bitmap_byte((ptr)si->list_bits)] |= segment_bitmap_bit((ptr)si->list_bits); + bits_si->marked_mask[segment_bitmap_byte(TO_PTR(si->list_bits))] |= segment_bitmap_bit(TO_PTR(si->list_bits)); } else { octet *copied_bits; - find_room(space_data, tg, typemod, ptr_align(segment_bitmap_bytes), copied_bits); + find_room_voidp(space_data, tg, ptr_align(segment_bitmap_bytes), copied_bits); memcpy_aligned(copied_bits, si->list_bits, segment_bitmap_bytes); si->list_bits = copied_bits; } @@ -2140,9 +2140,9 @@ static void init_measure(IGEN min_gen, IGEN max_gen) { min_measure_generation = min_gen; max_measure_generation = max_gen; - find_room(space_data, 0, typemod, init_stack_len, measure_stack_start); - measure_stack = (ptr *)measure_stack_start; - measure_stack_limit = (ptr *)((uptr)measure_stack_start + init_stack_len); + find_room_voidp(space_data, 0, init_stack_len, measure_stack_start); + measure_stack = TO_VOIDP(measure_stack_start); + measure_stack_limit = TO_VOIDP((uptr)TO_PTR(measure_stack_start) + init_stack_len); measured_seginfos = Snil; @@ -2154,14 +2154,14 @@ static void finish_measure() { for (ls = measured_seginfos; ls != Snil; ls = Scdr(ls)) { ptr pe, next_pe; - seginfo *si = (seginfo *)Scar(ls); + seginfo *si = TO_VOIDP(Scar(ls)); si->measured_mask = NULL; - for (pe = si->trigger_ephemerons; pe != NULL; pe = next_pe) { + for (pe = si->trigger_ephemerons; pe != 0; pe = next_pe) { next_pe = EPHEMERONNEXT(pe); - EPHEMERONPREVREF(pe) = NULL; - EPHEMERONNEXT(pe) = NULL; + EPHEMERONPREVREF(pe) = 0; + EPHEMERONNEXT(pe) = 0; } - si->trigger_ephemerons = NULL; + si->trigger_ephemerons = 0; } measure_all_enabled = 0; @@ -2173,7 +2173,7 @@ static void init_counting_mask(seginfo *si) { static void init_measure_mask(seginfo *si) { init_mask(si->measured_mask, 0, 0); - measured_seginfos = S_cons_in(space_new, 0, (ptr)si, measured_seginfos); + measured_seginfos = S_cons_in(space_new, 0, TO_PTR(si), measured_seginfos); } #define measure_unreached(si, p) \ @@ -2217,18 +2217,18 @@ static void push_measure(ptr p) if (si->trigger_ephemerons) { add_trigger_ephemerons_to_pending_measure(si->trigger_ephemerons); - si->trigger_ephemerons = NULL; + si->trigger_ephemerons = 0; } if (measure_stack == measure_stack_limit) { uptr sz = ptr_bytes * (measure_stack_limit - measure_stack_start); uptr new_sz = 2*sz; - ptr new_measure_stack; - find_room(space_data, 0, typemod, ptr_align(new_sz), new_measure_stack); + ptr *new_measure_stack; + find_room_voidp(space_data, 0, ptr_align(new_sz), new_measure_stack); memcpy(new_measure_stack, measure_stack_start, sz); - measure_stack_start = (ptr *)new_measure_stack; - measure_stack_limit = (ptr *)((uptr)new_measure_stack + new_sz); - measure_stack = (ptr *)((uptr)new_measure_stack + sz); + measure_stack_start = new_measure_stack; + measure_stack_limit = TO_VOIDP((uptr)TO_PTR(new_measure_stack) + new_sz); + measure_stack = TO_VOIDP((uptr)TO_PTR(new_measure_stack) + sz); } *(measure_stack++) = p; @@ -2266,8 +2266,8 @@ static void check_ephemeron_measure(ptr pe) { ptr p; seginfo *si; - EPHEMERONPREVREF(pe) = NULL; - EPHEMERONNEXT(pe) = NULL; + EPHEMERONPREVREF(pe) = 0; + EPHEMERONNEXT(pe) = 0; p = Scar(pe); if (!IMMEDIATE(p) && (si = MaybeSegInfo(ptr_get_segment(p))) != NULL @@ -2293,8 +2293,8 @@ static void check_pending_measure_ephemerons() { ptr pe, next_pe; pe = pending_measure_ephemerons; - pending_measure_ephemerons = NULL; - while (pe != NULL) { + pending_measure_ephemerons = 0; + while (pe != 0) { next_pe = EPHEMERONNEXT(pe); check_ephemeron_measure(pe); pe = next_pe; @@ -2306,7 +2306,7 @@ void gc_measure_one(ptr p) { if (si->trigger_ephemerons) { add_trigger_ephemerons_to_pending_measure(si->trigger_ephemerons); - si->trigger_ephemerons = NULL; + si->trigger_ephemerons = 0; } measure(p); @@ -2332,7 +2332,7 @@ IBOOL flush_measure_stack() { } ptr S_count_size_increments(ptr ls, IGEN generation) { - ptr l, totals = Snil, totals_prev = NULL; + ptr l, totals = Snil, totals_prev = 0; tc_mutex_acquire(); diff --git a/c/gcwrapper.c b/c/gcwrapper.c index bbd4f4ea02..c35293e917 100644 --- a/c/gcwrapper.c +++ b/c/gcwrapper.c @@ -530,10 +530,10 @@ void S_addr_tell(ptr p) { static void check_heap_dirty_msg(msg, x) char *msg; ptr *x; { INT d; seginfo *si; - si = SegInfo(addr_get_segment(x)); - d = (INT)(((uptr)x >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)); + si = SegInfo(addr_get_segment(TO_PTR(x))); + d = (INT)(((uptr)TO_PTR(x) >> card_offset_bits) & ((1 << segment_card_offset_bits) - 1)); printf("%s dirty byte %d found in segment %#tx, card %d at %#tx\n", msg, si->dirty_bytes[d], (ptrdiff_t)(si->number), d, (ptrdiff_t)x); - printf("from "); segment_tell(addr_get_segment(x)); + printf("from "); segment_tell(addr_get_segment(TO_PTR(x))); printf("to "); segment_tell(addr_get_segment(*x)); } @@ -638,18 +638,18 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { || s == space_immobile_impure || s == space_count_pure || s == space_count_impure || s == space_closure) { /* doesn't handle: space_port, space_continuation, space_code, space_pure_typed_object, space_impure_record, or impure_typed_object */ - nl = (ptr *)S_G.next_loc[s][g]; + nl = TO_VOIDP(S_G.next_loc[s][g]); /* check for dangling references */ - pp1 = (ptr *)build_ptr(seg, 0); - pp2 = (ptr *)build_ptr(seg + 1, 0); + pp1 = TO_VOIDP(build_ptr(seg, 0)); + pp2 = TO_VOIDP(build_ptr(seg + 1, 0)); if (pp1 <= nl && nl < pp2) pp2 = nl; while (pp1 < pp2) { - if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(pp1)] & segment_bitmap_bit(pp1))) { + if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { int a; for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) { -#define in_ephemeron_pair_part(pp1, seg) ((((uptr)(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair) +#define in_ephemeron_pair_part(pp1, seg) ((((uptr)TO_PTR(pp1) - (uptr)build_ptr(seg, 0)) % size_ephemeron) < size_pair) if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) { /* skip non-pair part of ephemeron */ } else { @@ -692,7 +692,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { if (s == space_impure || s == space_symbol || s == space_weakpair || s == space_ephemeron || s == space_immobile_impure || s == space_closure) { found_eos = 0; - pp2 = pp1 = build_ptr(seg, 0); + pp2 = pp1 = TO_VOIDP(build_ptr(seg, 0)); for (d = 0; d < cards_per_segment; d += 1) { if (found_eos) { if (si->dirty_bytes[d] != 0xff) { @@ -716,7 +716,7 @@ void S_check_heap(aftergc, mcg) IBOOL aftergc; IGEN mcg; { dirty = 0xff; while (pp1 < pp2) { - if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(pp1)] & segment_bitmap_bit(pp1))) { + if (!si->marked_mask || (si->marked_mask[segment_bitmap_byte(TO_PTR(pp1))] & segment_bitmap_bit(TO_PTR(pp1)))) { int a; for (a = 0; (a < ptr_alignment) && (pp1 < pp2); a++) { if ((s == space_ephemeron) && !in_ephemeron_pair_part(pp1, seg)) { @@ -890,25 +890,25 @@ static void check_locked_object(ptr p, IBOOL locked, IGEN g, IBOOL aftergc, IGEN seginfo *psi = MaybeSegInfo(ptr_get_segment(p)); if (!psi) { S_checkheap_errors += 1; - printf("!!! generation %d %s object has no segment: %p\n", g, what, p); + printf("!!! generation %d %s object has no segment: %p\n", g, what, TO_VOIDP(p)); } else { if (psi->generation != g) { S_checkheap_errors += 1; - printf("!!! generation %d %s object in generation %d segment: %p\n", g, what, psi->generation, p); + printf("!!! generation %d %s object in generation %d segment: %p\n", g, what, psi->generation, TO_VOIDP(p)); } if (!psi->must_mark && locked) { S_checkheap_errors += 1; - printf("!!! generation %d %s object not on must-mark page: %p\n", g, what, p); + printf("!!! generation %d %s object not on must-mark page: %p\n", g, what, TO_VOIDP(p)); } if (!psi->marked_mask) { if (aftergc && (psi->generation <= mcg)) { S_checkheap_errors += 1; - printf("!!! %s object not in marked segment: %p\n", what, p); + printf("!!! %s object not in marked segment: %p\n", what, TO_VOIDP(p)); printf(" in: "); segment_tell(psi->number); } } else if (!(psi->marked_mask[segment_bitmap_byte(p)] & segment_bitmap_bit(p))) { S_checkheap_errors += 1; - printf("!!! generation %d %s object not marked: %p\n", g, what, p); + printf("!!! generation %d %s object not marked: %p\n", g, what, TO_VOIDP(p)); } } } diff --git a/c/intern.c b/c/intern.c index 6ade458534..8bf951842e 100644 --- a/c/intern.c +++ b/c/intern.c @@ -40,20 +40,20 @@ void S_intern_init() { static void oblist_insert(ptr sym, iptr idx, IGEN g) { bucket *b, *oldb, **pb; - find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket), b); + find_room_voidp(g == 0 ? space_new : space_data, g, ptr_align(sizeof(bucket)), b); b->sym = sym; if (g == 0) { b->next = S_G.oblist[idx]; S_G.oblist[idx] = b; } else { - for (pb = &S_G.oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next); + for (pb = &S_G.oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(TO_PTR(oldb))) < g; pb = &oldb->next); b->next = oldb; *pb = b; } if (g != static_generation) { bucket_list *bl; - find_room(g == 0 ? space_new : space_data, g, typemod, sizeof(bucket_list), bl); + find_room_voidp(g == 0 ? space_new : space_data, g, ptr_align(sizeof(bucket_list)), bl); bl->car = b; bl->cdr = S_G.buckets_of_generation[g]; S_G.buckets_of_generation[g] = bl; @@ -85,7 +85,7 @@ void S_resize_oblist(void) { idx = OBINDEX(UNFIX(SYMHASH(sym)), new_oblist_length); g = GENERATION(sym); - for (pb = &new_oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(oldb)) < g; pb = &oldb->next) { + for (pb = &new_oblist[idx]; (oldb = *pb) != NULL && SegmentGeneration(addr_get_segment(TO_PTR(oldb))) < g; pb = &oldb->next) { inc++; if (done) dinc++; diff --git a/c/new-io.c b/c/new-io.c index d1ab66bb1c..840f3f77ef 100644 --- a/c/new-io.c +++ b/c/new-io.c @@ -51,9 +51,7 @@ #endif /* PTHREADS */ /* locally defined functions */ -static ptr new_open_output_fd_helper PROTO((const char *filename, INT mode, - INT flags, INT no_create, INT no_fail, INT no_truncate, - INT append, INT lock, INT replace, INT compressed)); +static ptr new_open_output_fd_helper PROTO((const char *filename, INT mode, INT flags, INT options)); static INT lockfile PROTO((INT fd)); static int is_valid_zlib_length(iptr count); static int is_valid_lz4_length(iptr count); @@ -144,9 +142,12 @@ static INT lockfile(INT fd) { return FLOCK(fd, LOCK_EX); } #ifdef LOCKF static INT lockfile(INT fd) { return lockf(fd, F_LOCK, (off_t)0); } #endif +#if !defined(FLOCK) && !defined(LOCKF) +static INT lockfile(INT fd) { return fd >= 0; } +#endif -#define MAKE_GZXFILE(x) Sinteger((iptr)x) -#define GZXFILE_GZFILE(x) ((glzFile)Sinteger_value(x)) +#define MAKE_GZXFILE(x) Sinteger((iptr)TO_PTR(x)) +#define GZXFILE_GZFILE(x) ((glzFile)TO_VOIDP(Sinteger_value(x))) INT S_gzxfile_fd(ptr x) { return GZXFILE_GZFILE(x)->fd; @@ -273,10 +274,7 @@ ptr S_compress_output_fd(INT fd) { return Sbox(MAKE_GZXFILE(file)); } -static ptr new_open_output_fd_helper( - const char *infilename, INT mode, INT flags, - IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, - IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) { +static ptr new_open_output_fd_helper( const char *infilename, INT mode, INT flags, INT options) { char *filename; INT saved_errno = 0; iptr error; @@ -284,14 +282,14 @@ static ptr new_open_output_fd_helper( ptr tc = get_thread_context(); flags |= - (no_create ? 0 : O_CREAT) | - ((no_fail || no_create) ? 0 : O_EXCL) | - (no_truncate ? 0 : O_TRUNC) | - ((!append) ? 0 : O_APPEND); + ((options & open_fd_no_create) ? 0 : O_CREAT) | + ((options & (open_fd_no_fail | open_fd_no_create)) ? 0 : O_EXCL) | + ((options & open_fd_no_truncate) ? 0 : O_TRUNC) | + ((!(options & open_fd_append)) ? 0 : O_APPEND); filename = S_malloc_pathname(infilename); - if (replace && UNLINK(filename) != 0 && errno != ENOENT) { + if ((options & open_fd_replace) && UNLINK(filename) != 0 && errno != ENOENT) { ptr str = S_strerror(errno); switch (errno) { case EACCES: @@ -324,7 +322,7 @@ static ptr new_open_output_fd_helper( } } - if (lock) { + if (options & open_fd_lock) { DEACTIVATE(tc) error = lockfile(fd); saved_errno = errno; @@ -335,7 +333,7 @@ static ptr new_open_output_fd_helper( } } - if (!compressed) { + if (!(options & open_fd_compressed)) { return MAKE_FD(fd); } @@ -349,27 +347,19 @@ static ptr new_open_output_fd_helper( return MAKE_GZXFILE(file); } -ptr S_new_open_output_fd( - const char *filename, INT mode, - IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, - IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) { +ptr S_new_open_output_fd(const char *filename, INT mode, INT options) { return new_open_output_fd_helper( filename, mode, O_BINARY | O_WRONLY, - no_create, no_fail, no_truncate, - append, lock, replace, compressed); + options); } -ptr S_new_open_input_output_fd( - const char *filename, INT mode, - IBOOL no_create, IBOOL no_fail, IBOOL no_truncate, - IBOOL append, IBOOL lock, IBOOL replace, IBOOL compressed) { - if (compressed) +ptr S_new_open_input_output_fd(const char *filename, INT mode, INT options) { + if (options & open_fd_compressed) return Sstring("compressed input/output files not supported"); else return new_open_output_fd_helper( filename, mode, O_BINARY | O_RDWR, - no_create, no_fail, no_truncate, - append, lock, replace, 0); + options); } ptr S_close_fd(ptr file, IBOOL gzflag) { diff --git a/c/number.c b/c/number.c index 52cd171d44..e2f5196bb2 100644 --- a/c/number.c +++ b/c/number.c @@ -732,12 +732,12 @@ void S_trunc_rem(tc, origx, y, q, r) ptr tc, origx, y, *q, *r; { if (Sfixnump(y)) { if (x == FIX(most_negative_fixnum) && y == FIX(-1)) { iptr m = most_negative_fixnum /* pull out to avoid bogus Sun C warning */; - if (q != (ptr)NULL) *q = Sinteger(-m); - if (r != (ptr)NULL) *r = FIX(0); + if (q != NULL) *q = Sinteger(-m); + if (r != NULL) *r = FIX(0); return; } else { - if (q != (ptr)NULL) *q = FIX((iptr)x / (iptr)y); - if (r != (ptr)NULL) *r = (ptr)((iptr)x % (iptr)y); + if (q != NULL) *q = FIX((iptr)x / (iptr)y); + if (r != NULL) *r = (ptr)((iptr)x % (iptr)y); return; } } else { diff --git a/c/pb.c b/c/pb.c new file mode 100644 index 0000000000..5b6a594d2c --- /dev/null +++ b/c/pb.c @@ -0,0 +1,929 @@ +#include "system.h" +#include +#include + +/* Interpreter for portable bytecode. See "pb.ss". */ + +typedef uint32_t instruction_t; + +#define INSTR_op(instr) ((instr) & 0xFF) + +#define INSTR_d_dest(instr) (((instr) >> 8) & 0xF) + +#define INSTR_dr_dest(instr) INSTR_d_dest(instr) +#define INSTR_dr_reg(instr) (((instr) >> 16) & 0xF) + +#define INSTR_di_dest(instr) INSTR_d_dest(instr) +#define INSTR_di_imm(instr) (((int32_t)(instr)) >> 16) +#define INSTR_di_imm_unsigned(instr) ((instr) >> 16) + +#define INSTR_drr_dest(instr) INSTR_d_dest(instr) +#define INSTR_drr_reg1(instr) (((instr) >> 12) & 0xF) +#define INSTR_drr_reg2(instr) (((instr) >> 16) & 0xF) + +#define INSTR_dri_dest(instr) INSTR_d_dest(instr) +#define INSTR_dri_reg(instr) (((instr) >> 12) & 0xF) +#define INSTR_dri_imm(instr) (((int32_t)(instr)) >> 16) + +#define INSTR_i_imm(instr) (((int32_t)(instr)) >> 8) + +#define SHIFT_MASK(v) ((v) & (ptr_bits-1)) + +static uptr regs[16]; +static double fpregs[8]; + +enum { + Cretval = 9, + Carg1 = 9, + Carg2, + Carg3, + Carg4, + Carg5, + Carg6, + Carg7 +}; + +enum { + Cfpretval = 1, + Cfparg1 = 1, + Cfparg2, + Cfparg3, + Cfparg4, + Cfparg5, + Cfparg6 +}; + +void S_machine_init() {} + +#define SIGN_FLIP(r, a, b) ((~((a ^ b) | (r ^ ~b))) >> (ptr_bits-1)) + +#if __GNUC__ >= 5 +# define USE_OVERFLOW_INTRINSICS 1 +#else +# define USE_OVERFLOW_INTRINSICS 0 +#endif + +#if 0 +# define TRACE(print, record) print +#elif 0 +# define TRACE(print, record) record +static instruction_t *branch_from, *branch_to; +static instruction_t *jump_from, *jump_to; +static instruction_t *interp_from, *interp_to; +static instruction_t *call_from; static void *call_to; +#else +# define TRACE(print, record) /* empty */ +#endif + +void S_pb_interp(ptr tc, void *bytecode) { + instruction_t *ip = (instruction_t *)bytecode, *next_ip, instr; + int flag = 0; + + regs[0] = (uptr)tc; + + TRACE(printf("enter %p\n", ip), ); + + while (1) { + instr = *ip; + next_ip = ip + 1; + + switch(INSTR_op(instr)) { + case pb_mov16_pb_zero_bits_pb_shift0: + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr); + break; + case pb_mov16_pb_zero_bits_pb_shift1: + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 16; + break; + case pb_mov16_pb_zero_bits_pb_shift2: +#if ptr_bits == 64 + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 32; +#else + regs[INSTR_di_dest(instr)] = 0; +#endif + break; + case pb_mov16_pb_zero_bits_pb_shift3: +#if ptr_bits == 64 + regs[INSTR_di_dest(instr)] = (uptr)INSTR_di_imm_unsigned(instr) << 48; +#else + regs[INSTR_di_dest(instr)] = 0; +#endif + break; + case pb_mov16_pb_keep_bits_pb_shift0: + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr); + break; + case pb_mov16_pb_keep_bits_pb_shift1: + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 16; + break; + case pb_mov16_pb_keep_bits_pb_shift2: +#if ptr_bits == 64 + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 32; +#endif + break; + case pb_mov16_pb_keep_bits_pb_shift3: +#if ptr_bits == 64 + regs[INSTR_di_dest(instr)] |= (uptr)INSTR_di_imm_unsigned(instr) << 48; +#endif + break; + case pb_mov_pb_i_i: + regs[INSTR_dr_dest(instr)] = regs[INSTR_dr_reg(instr)]; + break; + case pb_mov_pb_d_d: + fpregs[INSTR_dr_dest(instr)] = fpregs[INSTR_dr_reg(instr)]; + break; + case pb_mov_pb_i_d: + fpregs[INSTR_dr_dest(instr)] = (double)(iptr)regs[INSTR_dr_reg(instr)]; + break; + case pb_mov_pb_d_i: + regs[INSTR_dr_dest(instr)] = (iptr)fpregs[INSTR_dr_reg(instr)]; + break; +#if ptr_bits == 64 + case pb_mov_pb_i_bits_d_bits: + memcpy(&fpregs[INSTR_dr_dest(instr)], ®s[INSTR_dr_reg(instr)], sizeof(double)); + break; + case pb_mov_pb_d_bits_i_bits: + memcpy(®s[INSTR_dr_dest(instr)], &fpregs[INSTR_dr_reg(instr)], sizeof(double)); + break; +#else + case pb_mov_pb_i_i_bits_d_bits: + { + uint64_t d; + d = regs[INSTR_drr_reg1(instr)] | ((uint64_t)regs[INSTR_drr_reg2(instr)] << 32); + memcpy(&fpregs[INSTR_drr_dest(instr)], &d, sizeof(double)); + } + break; + case pb_mov_pb_d_lo_bits_i_bits: + { + uint64_t d; + memcpy(&d, &fpregs[INSTR_dr_reg(instr)], sizeof(double)); + regs[INSTR_dr_dest(instr)] = d; + } + break; + case pb_mov_pb_d_hi_bits_i_bits: + { + uint64_t d; + memcpy(&d, &fpregs[INSTR_dr_reg(instr)], sizeof(double)); + d >>= 32; + regs[INSTR_dr_dest(instr)] = d; + } + break; +#endif + case pb_mov_pb_s_d: + { + float f; +#ifdef PORTABLE_BYTECODE_BIGENDIAN + memcpy(&f, (char *)&fpregs[INSTR_dr_reg(instr)] + 4, sizeof(float)); +#else + memcpy(&f, &fpregs[INSTR_dr_reg(instr)], sizeof(float)); +#endif + fpregs[INSTR_dr_dest(instr)] = f; + } + break; + case pb_mov_pb_d_s: + { + float f; + f = fpregs[INSTR_dr_reg(instr)]; +#ifdef PORTABLE_BYTECODE_BIGENDIAN + memcpy((char *)&fpregs[INSTR_dr_dest(instr)] + 4, &f, sizeof(float)); +#else + memcpy(&fpregs[INSTR_dr_dest(instr)], &f, sizeof(float)); +#endif + } + break; + case pb_bin_op_pb_no_signal_pb_add_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]; + break; + case pb_bin_op_pb_no_signal_pb_add_pb_immediate: + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] + (uptr)INSTR_dri_imm(instr); + break; + case pb_bin_op_pb_no_signal_pb_sub_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; + break; + case pb_bin_op_pb_no_signal_pb_sub_pb_immediate: + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); + break; + case pb_bin_op_pb_no_signal_pb_mul_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] * regs[INSTR_drr_reg2(instr)]; + break; + case pb_bin_op_pb_no_signal_pb_mul_pb_immediate: + regs[INSTR_dri_dest(instr)] = (uptr)regs[INSTR_dri_reg(instr)] * (uptr)INSTR_dri_imm(instr); + break; + case pb_bin_op_pb_no_signal_pb_div_pb_register: + regs[INSTR_drr_dest(instr)] = (iptr)regs[INSTR_drr_reg1(instr)] / (iptr)regs[INSTR_drr_reg2(instr)]; + break; + case pb_bin_op_pb_no_signal_pb_div_pb_immediate: + regs[INSTR_dri_dest(instr)] = (iptr)regs[INSTR_dri_reg(instr)] / (iptr)INSTR_dri_imm(instr); + break; + case pb_bin_op_pb_no_signal_pb_and_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] & regs[INSTR_drr_reg2(instr)]; + break; + case pb_bin_op_pb_no_signal_pb_and_pb_immediate: + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] & (uptr)INSTR_dri_imm(instr); + break; + case pb_bin_op_pb_no_signal_pb_ior_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] | regs[INSTR_drr_reg2(instr)]; + break; + case pb_bin_op_pb_no_signal_pb_ior_pb_immediate: + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] | (uptr)INSTR_dri_imm(instr); + break; + case pb_bin_op_pb_no_signal_pb_xor_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] ^ regs[INSTR_drr_reg2(instr)]; + break; + case pb_bin_op_pb_no_signal_pb_xor_pb_immediate: + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] ^ (uptr)INSTR_dri_imm(instr); + break; + case pb_bin_op_pb_no_signal_pb_lsl_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] << SHIFT_MASK(regs[INSTR_drr_reg2(instr)]); + break; + case pb_bin_op_pb_no_signal_pb_lsl_pb_immediate: + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] << SHIFT_MASK(INSTR_dri_imm(instr)); + break; + case pb_bin_op_pb_no_signal_pb_lsr_pb_register: + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] >> SHIFT_MASK(regs[INSTR_drr_reg2(instr)]); + break; + case pb_bin_op_pb_no_signal_pb_lsr_pb_immediate: + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] >> SHIFT_MASK(INSTR_dri_imm(instr)); + break; + case pb_bin_op_pb_no_signal_pb_asr_pb_register: + regs[INSTR_drr_dest(instr)] = (iptr)regs[INSTR_drr_reg1(instr)] >> SHIFT_MASK(regs[INSTR_drr_reg2(instr)]); + break; + case pb_bin_op_pb_no_signal_pb_asr_pb_immediate: + regs[INSTR_dri_dest(instr)] = (iptr)regs[INSTR_dri_reg(instr)] >> SHIFT_MASK(INSTR_dri_imm(instr)); + break; + case pb_bin_op_pb_no_signal_pb_lslo_pb_register: +#ifdef PORTABLE_BYTECODE_BIGENDIAN + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] >> regs[INSTR_drr_reg2(instr)]; +#else + regs[INSTR_drr_dest(instr)] = regs[INSTR_drr_reg1(instr)] << regs[INSTR_drr_reg2(instr)]; +#endif + break; + case pb_bin_op_pb_no_signal_pb_lslo_pb_immediate: +#ifdef PORTABLE_BYTECODE_BIGENDIAN + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] >> INSTR_dri_imm(instr); +#else + regs[INSTR_dri_dest(instr)] = regs[INSTR_dri_reg(instr)] << INSTR_dri_imm(instr); +#endif + break; + case pb_bin_op_pb_signal_pb_add_pb_register: + { +#if USE_OVERFLOW_INTRINSICS + iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; + iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; + iptr r; + flag = __builtin_add_overflow(a, b, &r); + regs[INSTR_drr_dest(instr)] = (uptr)r; +#else + uptr a = regs[INSTR_drr_reg1(instr)]; + uptr b = regs[INSTR_drr_reg2(instr)]; + uptr r = a + b; + regs[INSTR_drr_dest(instr)] = r; + flag = SIGN_FLIP(r, a, b); +#endif + } + break; + case pb_bin_op_pb_signal_pb_add_pb_immediate: + { +#if USE_OVERFLOW_INTRINSICS + iptr a = (iptr)regs[INSTR_dri_reg(instr)]; + iptr b = INSTR_dri_imm(instr); + iptr r; + flag = __builtin_add_overflow(a, b, &r); + regs[INSTR_drr_dest(instr)] = (uptr)r; +#else + uptr a = regs[INSTR_dri_reg(instr)]; + uptr b = (uptr)INSTR_dri_imm(instr); + uptr r = a + b; + regs[INSTR_dri_dest(instr)] = r; + flag = SIGN_FLIP(r, a, b); +#endif + } + break; + case pb_bin_op_pb_signal_pb_sub_pb_register: + { +#if USE_OVERFLOW_INTRINSICS + iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; + iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; + iptr r; + flag = __builtin_sub_overflow(a, b, &r); + regs[INSTR_drr_dest(instr)] = (uptr)r; +#else + uptr a = regs[INSTR_drr_reg1(instr)]; + uptr b = regs[INSTR_drr_reg2(instr)]; + uptr r = a - b; + regs[INSTR_drr_dest(instr)] = r; + flag = SIGN_FLIP(r, a, ~b); +#endif + } + break; + case pb_bin_op_pb_signal_pb_sub_pb_immediate: + { +#if USE_OVERFLOW_INTRINSICS + iptr a = (iptr)regs[INSTR_dri_reg(instr)]; + iptr b = INSTR_dri_imm(instr); + iptr r; + flag = __builtin_sub_overflow(a, b, &r); + regs[INSTR_drr_dest(instr)] = (uptr)r; +#else + uptr a = regs[INSTR_dri_reg(instr)]; + uptr b = (uptr)INSTR_dri_imm(instr); + uptr r = a - b; + regs[INSTR_dri_dest(instr)] = r; + flag = SIGN_FLIP(r, a, ~b); +#endif + } + break; + case pb_bin_op_pb_signal_pb_mul_pb_register: + { +#if USE_OVERFLOW_INTRINSICS + iptr a = (iptr)regs[INSTR_drr_reg1(instr)]; + iptr b = (iptr)regs[INSTR_drr_reg2(instr)]; + iptr r; + flag = __builtin_mul_overflow(a, b, &r); + regs[INSTR_drr_dest(instr)] = (uptr)r; +#else + uptr a = regs[INSTR_drr_reg1(instr)]; + uptr b = regs[INSTR_drr_reg2(instr)]; + uptr r = a * b; + regs[INSTR_drr_dest(instr)] = r; + if (b != 0) { + if (b == (uptr)-1) + flag = (a != r * (uptr)-1); + else + flag = ((iptr)a != (iptr)r / (iptr)b); + } else + flag = 0; +#endif + } + break; + case pb_bin_op_pb_signal_pb_mul_pb_immediate: + { +#if USE_OVERFLOW_INTRINSICS + iptr a = (iptr)regs[INSTR_dri_reg(instr)]; + iptr b = INSTR_dri_imm(instr); + iptr r; + flag = __builtin_mul_overflow(a, b, &r); + regs[INSTR_drr_dest(instr)] = (uptr)r; +#else + uptr a = regs[INSTR_dri_reg(instr)]; + uptr b = (uptr)INSTR_dri_imm(instr); + uptr r = a * b; + regs[INSTR_dri_dest(instr)] = r; + if (b != 0) { + if (b == (uptr)-1) + flag = (a != r * (uptr)-1); + else + flag = ((iptr)a != (iptr)r / (iptr)b); + } else + flag = 0; +#endif + } + break; + case pb_bin_op_pb_signal_pb_subz_pb_register: + { + iptr r = regs[INSTR_drr_reg1(instr)] - regs[INSTR_drr_reg2(instr)]; + regs[INSTR_drr_dest(instr)] = r; + flag = (r == 0); + } + break; + case pb_bin_op_pb_signal_pb_subz_pb_immediate: + { + iptr r = regs[INSTR_dri_reg(instr)] - (uptr)INSTR_dri_imm(instr); + regs[INSTR_dri_dest(instr)] = r; + flag = (r == 0); + } + break; + case pb_cmp_op_pb_eq_pb_register: + flag = regs[INSTR_dr_dest(instr)] == regs[INSTR_dr_reg(instr)]; + break; + case pb_cmp_op_pb_eq_pb_immediate: + flag = regs[INSTR_di_dest(instr)] == (uptr)INSTR_di_imm(instr); + break; + case pb_cmp_op_pb_lt_pb_register: + flag = (iptr)regs[INSTR_dr_dest(instr)] < (iptr)regs[INSTR_dr_reg(instr)]; + break; + case pb_cmp_op_pb_lt_pb_immediate: + flag = (iptr)regs[INSTR_di_dest(instr)] < (iptr)INSTR_di_imm(instr); + break; + case pb_cmp_op_pb_gt_pb_register: + flag = (iptr)regs[INSTR_dr_dest(instr)] > (iptr)regs[INSTR_dr_reg(instr)]; + break; + case pb_cmp_op_pb_gt_pb_immediate: + flag = (iptr)regs[INSTR_di_dest(instr)] > (iptr)INSTR_di_imm(instr); + break; + case pb_cmp_op_pb_le_pb_register: + flag = (iptr)regs[INSTR_dr_dest(instr)] <= (iptr)regs[INSTR_dr_reg(instr)]; + break; + case pb_cmp_op_pb_le_pb_immediate: + flag = (iptr)regs[INSTR_di_dest(instr)] <= (iptr)INSTR_di_imm(instr); + break; + case pb_cmp_op_pb_ge_pb_register: + flag = (iptr)regs[INSTR_dr_dest(instr)] >= (iptr)regs[INSTR_dr_reg(instr)]; + break; + case pb_cmp_op_pb_ge_pb_immediate: + flag = (iptr)regs[INSTR_di_dest(instr)] >= (iptr)INSTR_di_imm(instr); + break; + case pb_cmp_op_pb_ab_pb_register: + flag = regs[INSTR_dr_dest(instr)] > regs[INSTR_dr_reg(instr)]; + break; + case pb_cmp_op_pb_ab_pb_immediate: + flag = regs[INSTR_di_dest(instr)] > (uptr)INSTR_di_imm(instr); + break; + case pb_cmp_op_pb_bl_pb_register: + flag = regs[INSTR_dr_dest(instr)] < regs[INSTR_dr_reg(instr)]; + break; + case pb_cmp_op_pb_bl_pb_immediate: + flag = regs[INSTR_di_dest(instr)] < (uptr)INSTR_di_imm(instr); + break; + case pb_cmp_op_pb_cs_pb_register: + flag = ((regs[INSTR_dr_dest(instr)] & regs[INSTR_dr_reg(instr)]) != 0); + break; + case pb_cmp_op_pb_cs_pb_immediate: + flag = ((regs[INSTR_di_dest(instr)] & (uptr)INSTR_di_imm(instr)) != 0); + break; + case pb_cmp_op_pb_cc_pb_register: + flag = ((regs[INSTR_dr_dest(instr)] & regs[INSTR_dr_reg(instr)]) == 0); + break; + case pb_cmp_op_pb_cc_pb_immediate: + flag = ((regs[INSTR_di_dest(instr)] & (uptr)INSTR_di_imm(instr)) == 0); + break; + case pb_fp_bin_op_pb_add_pb_register: + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] + fpregs[INSTR_drr_reg2(instr)]; + break; + case pb_fp_bin_op_pb_sub_pb_register: + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] - fpregs[INSTR_drr_reg2(instr)]; + break; + case pb_fp_bin_op_pb_mul_pb_register: + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] * fpregs[INSTR_drr_reg2(instr)]; + break; + case pb_fp_bin_op_pb_div_pb_register: + fpregs[INSTR_drr_dest(instr)] = fpregs[INSTR_drr_reg1(instr)] / fpregs[INSTR_drr_reg2(instr)]; + break; + case pb_un_op_pb_not_pb_register: + regs[INSTR_dr_dest(instr)] = ~(regs[INSTR_dr_reg(instr)]); + break; + case pb_un_op_pb_not_pb_immediate: + regs[INSTR_di_dest(instr)] = ~((uptr)(iptr)INSTR_di_imm(instr)); + break; + case pb_fp_un_op_pb_sqrt_pb_register: + fpregs[INSTR_dr_dest(instr)] = sqrt(fpregs[INSTR_dr_reg(instr)]); + break; + case pb_fp_cmp_op_pb_eq_pb_register: + flag = fpregs[INSTR_dr_dest(instr)] == fpregs[INSTR_dr_reg(instr)]; + break; + case pb_fp_cmp_op_pb_lt_pb_register: + flag = fpregs[INSTR_dr_dest(instr)] < fpregs[INSTR_dr_reg(instr)]; + break; + case pb_fp_cmp_op_pb_le_pb_register: + flag = fpregs[INSTR_dr_dest(instr)] <= fpregs[INSTR_dr_reg(instr)]; + break; + case pb_rev_op_pb_int16_pb_register: +#if ptr_bits == 64 + regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 56) >> 48) + | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)); +#else + regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 24) >> 16) + | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)); +#endif + break; + case pb_rev_op_pb_uint16_pb_register: + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & 0x00FF) << 8) + | ((regs[INSTR_dr_reg(instr)] & 0xFF00) >> 8)); + break; + case pb_rev_op_pb_int32_pb_register: +#if ptr_bits == 64 + regs[INSTR_dr_dest(instr)] = ((uptr)((iptr)(regs[INSTR_dr_reg(instr)] << 56) >> 32) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); +#else + regs[INSTR_dr_dest(instr)] = ((regs[INSTR_dr_reg(instr)] << 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); +#endif + break; + case pb_rev_op_pb_uint32_pb_register: + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF) << 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); + break; + case pb_rev_op_pb_int64_pb_register: +#if ptr_bits == 64 + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x00000000000000FF) << 56) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x000000000000FF00) << 40) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000000000FF0000) << 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00000000FF000000) << 8) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF00000000) >> 8) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF0000000000) >> 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF000000000000) >> 40) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF00000000000000) >> 56)); +#else + regs[INSTR_dr_dest(instr)] = (((regs[INSTR_dr_reg(instr)] & (uptr)0x000000FF) << 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0xFF000000) >> 24) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x00FF0000) >> 8) + | ((regs[INSTR_dr_reg(instr)] & (uptr)0x0000FF00) << 8)); +#endif + break; + case pb_ld_op_pb_int8_pb_register: + regs[INSTR_drr_dest(instr)] = *(int8_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_int8_pb_immediate: + regs[INSTR_dri_dest(instr)] = *(int8_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_uint8_pb_register: + regs[INSTR_drr_dest(instr)] = *(uint8_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_uint8_pb_immediate: + regs[INSTR_dri_dest(instr)] = *(uint8_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_int16_pb_register: + regs[INSTR_drr_dest(instr)] = *(int16_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_int16_pb_immediate: + regs[INSTR_dri_dest(instr)] = *(int16_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_uint16_pb_register: + regs[INSTR_drr_dest(instr)] = *(uint16_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_uint16_pb_immediate: + regs[INSTR_dri_dest(instr)] = *(uint16_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_int32_pb_register: + regs[INSTR_drr_dest(instr)] = *(int32_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_int32_pb_immediate: + regs[INSTR_dri_dest(instr)] = *(int32_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_uint32_pb_register: + regs[INSTR_drr_dest(instr)] = *(uint32_t *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_uint32_pb_immediate: + regs[INSTR_dri_dest(instr)] = *(uint32_t *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_int64_pb_register: + regs[INSTR_drr_dest(instr)] = *(uptr *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_int64_pb_immediate: + regs[INSTR_dri_dest(instr)] = *(uptr *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_double_pb_register: + fpregs[INSTR_drr_dest(instr)] = *(double *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_double_pb_immediate: + fpregs[INSTR_dri_dest(instr)] = *(double *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_ld_op_pb_single_pb_register: + fpregs[INSTR_drr_dest(instr)] = *(float *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]); + break; + case pb_ld_op_pb_single_pb_immediate: + fpregs[INSTR_dri_dest(instr)] = *(float *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)); + break; + case pb_st_op_pb_int8_pb_register: + *(char *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (char)regs[INSTR_drr_dest(instr)]; + break; + case pb_st_op_pb_int8_pb_immediate: + *(char *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (char)regs[INSTR_dri_dest(instr)]; + break; + case pb_st_op_pb_int16_pb_register: + *(short *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (short)regs[INSTR_drr_dest(instr)]; + break; + case pb_st_op_pb_int16_pb_immediate: + *(short *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (short)regs[INSTR_dri_dest(instr)]; + break; + case pb_st_op_pb_int32_pb_register: + *(int *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = (int)regs[INSTR_drr_dest(instr)]; + break; + case pb_st_op_pb_int32_pb_immediate: + *(int *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = (int)regs[INSTR_dri_dest(instr)]; + break; + case pb_st_op_pb_int64_pb_register: + *(uptr *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = regs[INSTR_drr_dest(instr)]; + break; + case pb_st_op_pb_int64_pb_immediate: + *(uptr *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = regs[INSTR_dri_dest(instr)]; + break; + case pb_st_op_pb_double_pb_register: + *(double *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = fpregs[INSTR_drr_dest(instr)]; + break; + case pb_st_op_pb_double_pb_immediate: + *(double *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = fpregs[INSTR_dri_dest(instr)]; + break; + case pb_st_op_pb_single_pb_register: + *(float *)TO_VOIDP(regs[INSTR_drr_reg1(instr)] + regs[INSTR_drr_reg2(instr)]) = fpregs[INSTR_drr_dest(instr)]; + break; + case pb_st_op_pb_single_pb_immediate: + *(float *)TO_VOIDP(regs[INSTR_dri_reg(instr)] + INSTR_dri_imm(instr)) = fpregs[INSTR_dri_dest(instr)]; + break; + case pb_b_op_pb_fals_pb_register: + if (!flag) { + next_ip = (instruction_t *)TO_VOIDP(regs[INSTR_dr_reg(instr)]); + TRACE(printf("branch %p -> %p\n", ip, next_ip), { branch_from = ip; branch_to = next_ip; }); + } + break; + case pb_b_op_pb_fals_pb_immediate: + if (!flag) { + next_ip = (instruction_t *)TO_VOIDP((char *)next_ip + INSTR_i_imm(instr)); + TRACE(printf("branch %p -> %p\n", ip, next_ip), { branch_from = ip; branch_to = next_ip; }); + } + break; + case pb_b_op_pb_true_pb_register: + if (flag) { + next_ip = (instruction_t *)TO_VOIDP(regs[INSTR_dr_reg(instr)]); + TRACE(printf("branch %p -> %p\n", ip, next_ip), { branch_from = ip; branch_to = next_ip; }); + } + break; + case pb_b_op_pb_true_pb_immediate: + if (flag) { + next_ip = (instruction_t *)TO_VOIDP((char *)next_ip + INSTR_i_imm(instr)); + TRACE(printf("branch %p -> %p\n", ip, next_ip), { branch_from = ip; branch_to = next_ip; }); + } + break; + case pb_b_op_pb_always_pb_register: + next_ip = (instruction_t *)TO_VOIDP(regs[INSTR_dr_reg(instr)]); + TRACE(printf("jump %p -> %p\n", ip, next_ip), { jump_from = ip; jump_to = next_ip; }); + break; + case pb_b_op_pb_always_pb_immediate: + next_ip = (instruction_t *)TO_VOIDP((char *)next_ip + INSTR_i_imm(instr)); + TRACE(printf("jump %p -> %p\n", ip, next_ip), { jump_from = ip; jump_to = next_ip; }); + break; + case pb_bs_op_pb_register: + next_ip = (instruction_t *)TO_VOIDP(*(uptr *)TO_VOIDP(regs[INSTR_dr_dest(instr)] + regs[INSTR_dr_reg(instr)])); + TRACE(printf("jump %p -> %p\n", ip, next_ip), { jump_from = ip; jump_to = next_ip; }); + break; + case pb_bs_op_pb_immediate: + next_ip = (instruction_t *)TO_VOIDP(*(uptr *)TO_VOIDP(regs[INSTR_di_dest(instr)] + INSTR_di_imm(instr))); + TRACE(printf("jump %p -> %p\n", ip, next_ip), { jump_from = ip; jump_to = next_ip; }); + break; + case pb_return: + return; /* <--- not break */ + case pb_adr: + regs[INSTR_di_dest(instr)] = (uptr)TO_PTR(next_ip) + INSTR_di_imm(instr); + break; + case pb_interp: + { + void *code = TO_VOIDP(regs[INSTR_d_dest(instr)]); + TRACE(printf("interp %p -> %p\n", ip, code), { interp_from = ip; interp_to = (instruction_t *)regs[0]; }); + S_pb_interp((ptr)regs[0], code); + } + break; + case pb_call: + { + void *proc = TO_VOIDP(regs[INSTR_dri_dest(instr)]); + TRACE(printf("call %p -> %p %x\n", ip, proc, INSTR_dri_imm(instr)), { call_from = ip; call_to = proc; }); + switch (INSTR_dri_imm(instr)) { + case pb_call_void: + ((pb_void_t)proc)(); + break; + case pb_call_void_uptr: + ((pb_void_uptr_t)proc)(regs[Carg1]); + break; + case pb_call_void_int32: + ((pb_void_int32_t)proc)(regs[Carg1]); + break; + case pb_call_void_uint32: + ((pb_void_uint32_t)proc)(regs[Carg1]); + break; + case pb_call_void_voids: + ((pb_void_voids_t)proc)(TO_VOIDP(regs[Carg1])); + break; + case pb_call_void_uptr_uint32: + ((pb_void_uptr_uint32_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_void_int32_uptr: + ((pb_void_int32_uptr_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_void_int32_voids: + ((pb_void_int32_voids_t)proc)(regs[Carg1], TO_VOIDP(regs[Carg2])); + break; + case pb_call_void_uptr_voids: + ((pb_void_uptr_voids_t)proc)(regs[Carg1], TO_VOIDP(regs[Carg2])); + break; + case pb_call_void_int32_int32: + ((pb_void_int32_int32_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_void_uptr_uptr: + ((pb_void_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_void_voids_voids: + ((pb_void_voids_voids_t)proc)(TO_VOIDP(regs[Carg1]), TO_VOIDP(regs[Carg2])); + break; + case pb_call_void_uptr_uptr_uptr: + ((pb_void_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3]); + break; + case pb_call_void_uptr_uptr_uptr_uptr_uptr: + ((pb_void_uptr_uptr_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4], regs[Carg5]); + break; + case pb_call_int32: + regs[Cretval] = ((pb_int32_t)proc)(); + break; + case pb_call_int32_uptr: + regs[Cretval] = ((pb_int32_uptr_t)proc)(regs[Carg1]); + break; + case pb_call_int32_voids: + regs[Cretval] = ((pb_int32_voids_t)proc)(TO_VOIDP(regs[Carg1])); + break; + case pb_call_int32_uptr_int32: + regs[Cretval] = ((pb_int32_uptr_int32_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_int32_uptr_uptr: + regs[Cretval] = ((pb_int32_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_int32_int32_int32: + regs[Cretval] = ((pb_int32_int32_int32_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_int32_voids_int32: + regs[Cretval] = ((pb_int32_voids_int32_t)proc)(TO_VOIDP(regs[Carg1]), regs[Carg2]); + break; + case pb_call_int32_int32_voids: + regs[Cretval] = ((pb_int32_int32_voids_t)proc)(regs[Carg1], TO_VOIDP(regs[Carg2])); + break; + case pb_call_int32_double_double_double_double_double_double: + regs[Cretval] = ((pb_int32_double_double_double_double_double_double_t)proc)(fpregs[Cfparg1], fpregs[Cfparg2], fpregs[Cfparg3], + fpregs[Cfparg4], fpregs[Cfparg5], fpregs[Cfparg6]); + break; + case pb_call_uint32: + regs[Cretval] = ((pb_uint32_t)proc)(); + break; + case pb_call_double_double: + fpregs[Cfpretval] = ((pb_double_double_t)proc)(fpregs[Cfparg1]); + break; + case pb_call_double_uptr: + fpregs[Cfpretval] = ((pb_double_uptr_t)proc)(regs[Carg1]); + break; + case pb_call_double_double_double: + fpregs[Cfpretval] = ((pb_double_double_double_t)proc)(fpregs[Cfparg1], fpregs[Cfparg2]); + break; + case pb_call_int32_int32: + regs[Cretval] = ((pb_int32_int32_t)proc)(regs[Carg1]); + break; + case pb_call_int32_int32_uptr: + regs[Cretval] = ((pb_int32_int32_uptr_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_int32_voids_voids_voids_voids_uptr: + regs[Cretval] = ((pb_int32_voids_voids_voids_voids_uptr_t)proc)(TO_VOIDP(regs[Carg1]), TO_VOIDP(regs[Carg2]), TO_VOIDP(regs[Carg3]), + TO_VOIDP(regs[Carg4]), regs[Carg5]); + break; + case pb_call_uptr: + regs[Cretval] = ((pb_uptr_t)proc)(); + break; + case pb_call_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_t)proc)(regs[Carg1]); + break; + case pb_call_uptr_int32: + regs[Cretval] = ((pb_uptr_int32_t)proc)(regs[Carg1]); + break; + case pb_call_uptr_voids: + regs[Cretval] = ((pb_uptr_voids_t)proc)(TO_VOIDP(regs[Carg1])); + break; + case pb_call_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_uptr_uptr_int32: + regs[Cretval] = ((pb_uptr_uptr_int32_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_uptr_uptr_int64: +#if ptr_bits == 64 + regs[Cretval] = ((pb_uptr_uptr_int64_t)proc)(regs[Carg1], regs[Carg2]); +#else + regs[Cretval] = ((pb_uptr_uptr_int64_t)proc)(regs[Carg1], regs[Carg2] | ((int64_t)regs[Carg3] << 32)); +#endif + break; + case pb_call_uptr_int32_uptr: + regs[Cretval] = ((pb_uptr_int32_uptr_t)proc)(regs[Carg1], regs[Carg2]); + break; + case pb_call_uptr_voids_uptr: + regs[Cretval] = ((pb_uptr_voids_uptr_t)proc)(TO_VOIDP(regs[Carg1]), regs[Carg2]); + break; + case pb_call_uptr_uptr_voids: + regs[Cretval] = ((pb_uptr_uptr_voids_t)proc)(regs[Carg1], TO_VOIDP(regs[Carg2])); + break; + case pb_call_uptr_voids_int32: + regs[Cretval] = ((pb_uptr_voids_int32_t)proc)(TO_VOIDP(regs[Carg1]), regs[Carg2]); + break; + case pb_call_uptr_voids_voids: + regs[Cretval] = ((pb_uptr_voids_voids_t)proc)(TO_VOIDP(regs[Carg1]), TO_VOIDP(regs[Carg2])); + break; + case pb_call_uptr_uptr_int32_int32: + regs[Cretval] = ((pb_uptr_uptr_int32_int32_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3]); + break; + case pb_call_uptr_voids_int32_int32: + regs[Cretval] = ((pb_uptr_voids_int32_int32_t)proc)(TO_VOIDP(regs[Carg1]), regs[Carg2], regs[Carg3]); + break; + case pb_call_uptr_voids_uptr_uptr: + regs[Cretval] = ((pb_uptr_voids_uptr_uptr_t)proc)(TO_VOIDP(regs[Carg1]), regs[Carg2], regs[Carg3]); + break; + case pb_call_uptr_uptr_uptr_int32: + regs[Cretval] = ((pb_uptr_uptr_uptr_int32_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3]); + break; + case pb_call_uptr_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3]); + break; + case pb_call_uptr_int32_int32_uptr: + regs[Cretval] = ((pb_uptr_int32_int32_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3]); + break; + case pb_call_uptr_int32_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_int32_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4]); + break; + case pb_call_uptr_uptr_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4]); + break; + case pb_call_uptr_int32_int32_uptr_uptr: + regs[Cretval] = ((pb_uptr_int32_int32_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4]); + break; + case pb_call_uptr_int32_voids_uptr_uptr: + regs[Cretval] = ((pb_uptr_int32_voids_uptr_uptr_t)proc)(regs[Carg1], TO_VOIDP(regs[Carg2]), regs[Carg3], + regs[Carg4]); + break; + case pb_call_uptr_uptr_uptr_uptr_uptr_int32: + regs[Cretval] = ((pb_uptr_uptr_uptr_uptr_uptr_int32_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4], regs[Carg5]); + break; + case pb_call_uptr_uptr_uptr_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_uptr_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4], regs[Carg5]); + break; + case pb_call_uptr_voids_voids_voids_voids_uptr: + regs[Cretval] = ((pb_uptr_voids_voids_voids_voids_uptr_t)proc)(TO_VOIDP(regs[Carg1]), TO_VOIDP(regs[Carg2]), TO_VOIDP(regs[Carg3]), + TO_VOIDP(regs[Carg4]), regs[Carg5]); + break; + case pb_call_uptr_uptr_int32_uptr_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_int32_uptr_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4], regs[Carg5], regs[Carg6]); + break; + case pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_uptr_uptr_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4], regs[Carg5], regs[Carg6]); + break; + case pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr_int32: + regs[Cretval] = ((pb_uptr_uptr_uptr_uptr_uptr_uptr_uptr_int32_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4], regs[Carg5], regs[Carg6], + regs[Carg7]); + break; + case pb_call_uptr_uptr_uptr_uptr_uptr_uptr_uptr_uptr: + regs[Cretval] = ((pb_uptr_uptr_uptr_uptr_uptr_uptr_uptr_uptr_t)proc)(regs[Carg1], regs[Carg2], regs[Carg3], + regs[Carg4], regs[Carg5], regs[Carg6], + regs[Carg7]); + break; + case pb_call_uptr_double_double_double_double_double_double: + regs[Cretval] = ((pb_uptr_double_double_double_double_double_double_t)proc)(fpregs[Cfparg1], fpregs[Cfparg2], fpregs[Cfparg3], + fpregs[Cfparg4], fpregs[Cfparg5], fpregs[Cfparg6]); + break; + case pb_call_voids: + regs[Cretval] = TO_PTR(((pb_voids_t)proc)()); + break; + case pb_call_voids_uptr: + regs[Cretval] = TO_PTR(((pb_voids_uptr_t)proc)(regs[Carg1])); + break; + default: + S_error_abort("unsupported call prototype"); + break; + } + } + break; + case pb_inc_pb_register: + { + uptr r = *(uptr *)TO_VOIDP(regs[INSTR_dr_dest(instr)]) + regs[INSTR_dr_reg(instr)]; + *(uptr *)TO_VOIDP(regs[INSTR_dr_dest(instr)]) = r; + flag = (r == 0); + } + break; + case pb_inc_pb_immediate: + { + uptr r = *(uptr *)TO_VOIDP(regs[INSTR_di_dest(instr)]) + INSTR_di_imm(instr); + *(uptr *)TO_VOIDP(regs[INSTR_di_dest(instr)]) = r; + flag = (r == 0); + } + break; + case pb_lock: + { + uptr *l = TO_VOIDP(regs[INSTR_d_dest(instr)]); + if (*l == 0) { + *l = 1; + flag = 1; + } else + flag = 0; + } + break; + case pb_cas: + { + uptr *l = TO_VOIDP(regs[INSTR_drr_dest(instr)]); + uptr old = regs[INSTR_drr_reg1(instr)]; + uptr new = regs[INSTR_drr_reg2(instr)]; + if (*l == old) { + *l = new; + flag = 1; + } else + flag = 0; + } + break; + default: + S_error_abort("illegal pb instruction"); + break; + } + ip = next_ip; + } +} diff --git a/c/prim.c b/c/prim.c index b5440173aa..4798fd67fd 100644 --- a/c/prim.c +++ b/c/prim.c @@ -45,6 +45,10 @@ static void install_library_entry(n, x) ptr n, x; { if (n == FIX(library_cpu_features)) x86_64_set_popcount_present(x); #endif +#ifdef PORTABLE_BYTECODE_BIGENDIAN + if (n == FIX(library_dounderflow)) + S_swap_dounderflow_header_endian(CLOSCODE(x)); +#endif } ptr S_lookup_library_entry(n, errorp) iptr n; IBOOL errorp; { @@ -81,7 +85,7 @@ ptr int2ptr(iptr f) return (ptr)(f & ~0x3); } #else /* HPUX */ -#define proc2ptr(x) (ptr)(iptr)(x) +#define proc2ptr(x) TO_PTR(x) #endif /* HPUX */ void S_install_c_entry(i, x) iptr i; ptr x; { @@ -122,12 +126,12 @@ static void create_c_entry_vector() { S_install_c_entry(CENTRY_handle_overflow, proc2ptr(S_handle_overflow)); S_install_c_entry(CENTRY_handle_overflood, proc2ptr(S_handle_overflood)); S_install_c_entry(CENTRY_handle_nonprocedure_symbol, proc2ptr(S_handle_nonprocedure_symbol)); - S_install_c_entry(CENTRY_thread_list, (ptr)&S_threads); + S_install_c_entry(CENTRY_thread_list, TO_PTR(&S_threads)); S_install_c_entry(CENTRY_split_and_resize, proc2ptr(S_split_and_resize)); #ifdef PTHREADS - S_install_c_entry(CENTRY_raw_collect_cond, (ptr)&S_collect_cond); - S_install_c_entry(CENTRY_raw_collect_thread0_cond, (ptr)&S_collect_thread0_cond); - S_install_c_entry(CENTRY_raw_tc_mutex, (ptr)&S_tc_mutex); + S_install_c_entry(CENTRY_raw_collect_cond, TO_PTR(&S_collect_cond)); + S_install_c_entry(CENTRY_raw_collect_thread0_cond, TO_PTR(&S_collect_thread0_cond)); + S_install_c_entry(CENTRY_raw_tc_mutex, TO_PTR(&S_tc_mutex)); S_install_c_entry(CENTRY_activate_thread, proc2ptr(S_activate_thread)); S_install_c_entry(CENTRY_deactivate_thread, proc2ptr(Sdeactivate_thread)); S_install_c_entry(CENTRY_unactivate_thread, proc2ptr(S_unactivate_thread)); diff --git a/c/prim5.c b/c/prim5.c index 0bcfe5d004..4258cf1f22 100644 --- a/c/prim5.c +++ b/c/prim5.c @@ -25,8 +25,8 @@ /* locally defined functions */ static INT s_errno PROTO((void)); -static iptr s_addr_in_heap PROTO((uptr x)); -static iptr s_ptr_in_heap PROTO((ptr x)); +static IBOOL s_addr_in_heap PROTO((uptr x)); +static IBOOL s_ptr_in_heap PROTO((ptr x)); static ptr s_generation PROTO((ptr x)); static iptr s_fxmul PROTO((iptr x, iptr y)); static iptr s_fxdiv PROTO((iptr x, iptr y)); @@ -146,11 +146,11 @@ static INT s_errno() { return errno; } -static iptr s_addr_in_heap(x) uptr x; { +static IBOOL s_addr_in_heap(x) uptr x; { return MaybeSegInfo(addr_get_segment(x)) != NULL; } -static iptr s_ptr_in_heap(x) ptr x; { +static IBOOL s_ptr_in_heap(x) ptr x; { return MaybeSegInfo(ptr_get_segment(x)) != NULL; } @@ -258,7 +258,7 @@ static ptr s_decode_float(x) ptr x; { } #define FMTBUFSIZE 120 -#define CHUNKADDRLT(x, y) (((chunkinfo *)(Scar(x)))->addr < ((chunkinfo *)(Scar(y)))->addr) +#define CHUNKADDRLT(x, y) (((chunkinfo *)TO_VOIDP(Scar(x)))->addr < ((chunkinfo *)TO_VOIDP(Scar(y)))->addr) mkmergesort(sort_chunks, merge_chunks, ptr, Snil, CHUNKADDRLT, INITCDR) static ptr sorted_chunk_list(void) { @@ -266,7 +266,7 @@ static ptr sorted_chunk_list(void) { for (i = PARTIAL_CHUNK_POOLS; i >= -1; i -= 1) { for (chunk = (i == -1) ? S_chunks_full : S_chunks[i]; chunk != NULL; chunk = chunk->next) { - ls = Scons(chunk, ls); + ls = Scons(TO_PTR(chunk), ls); n += 1; } } @@ -347,7 +347,7 @@ static void s_show_chunks(FILE *out, ptr sorted_chunks) { ptr ls; for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { - chunk = Scar(ls); + chunk = TO_VOIDP(Scar(ls)); max_addr = chunk->addr; if (chunk->segs > max_segs) max_segs = chunk->segs; if ((void *)chunk > max_header_addr) max_header_addr = (void *)chunk; @@ -367,7 +367,7 @@ static void s_show_chunks(FILE *out, ptr sorted_chunks) { snprintf(fmtbuf, FMTBUFSIZE, "%%#0%dtx %%#0%dtx (+ %%#0%dtx bytes @ %%#0%dtx) %%%dtd of %%%dtd\n", addrwidth, byteswidth, headerbyteswidth, headeraddrwidth, segswidth, segswidth); for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { - chunk = Scar(ls); + chunk = TO_VOIDP(Scar(ls)); fprintf(out, fmtbuf, (ptrdiff_t)chunk->addr, (ptrdiff_t)chunk->bytes, (ptrdiff_t)(sizeof(chunkinfo) + sizeof(seginfo) * chunk->segs), (ptrdiff_t)chunk, (ptrdiff_t)chunk->nused_segs, (ptrdiff_t)chunk->segs); @@ -422,7 +422,7 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) { bytes[s][g] += S_G.bytes_of_space[s][g]; /* add in bytes in active segments */ if (S_G.next_loc[s][g] != FIX(0)) - bytes[s][g] += (char *)S_G.next_loc[s][g] - (char *)S_G.base_loc[s][g]; + bytes[s][g] += (uptr)S_G.next_loc[s][g] - (uptr)S_G.base_loc[s][g]; } } @@ -529,7 +529,7 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) { for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { iptr last_seg; - chunk = Scar(ls); + chunk = TO_VOIDP(Scar(ls)); last_seg = chunk->base + chunk->segs; if (last_seg > max_seg) max_seg = last_seg; } @@ -544,7 +544,7 @@ static void s_showalloc(IBOOL show_dump, const char *outfn) { for (ls = sorted_chunks; ls != Snil; ls = Scdr(ls)) { seginfo *si; - chunk = Scar(ls); + chunk = TO_VOIDP(Scar(ls)); if (chunk->base != next_base && segsprinted != 0) { for (;;) { @@ -849,14 +849,14 @@ static I32 s_chdir(const char *inpath) { #ifdef GETWD static char *s_getwd() { - return GETWD((char *)&BVIT(S_bytevector(PATH_MAX), 0)); + return GETWD(TO_VOIDP(&BVIT(S_bytevector(PATH_MAX), 0))); } #endif /* GETWD */ static ptr s_set_code_byte(p, n, x) ptr p, n, x; { I8 *a; - a = (I8 *)((uptr)p + UNFIX(n)); + a = (I8 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I8)UNFIX(x); return Svoid; } @@ -864,7 +864,7 @@ static ptr s_set_code_byte(p, n, x) ptr p, n, x; { static ptr s_set_code_word(p, n, x) ptr p, n, x; { I16 *a; - a = (I16 *)((uptr)p + UNFIX(n)); + a = (I16 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I16)UNFIX(x); return Svoid; } @@ -872,7 +872,7 @@ static ptr s_set_code_word(p, n, x) ptr p, n, x; { static ptr s_set_code_long(p, n, x) ptr p, n, x; { I32 *a; - a = (I32 *)((uptr)p + UNFIX(n)); + a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I32)(Sfixnump(x) ? UNFIX(x) : Sinteger_value(x)); return Svoid; } @@ -880,14 +880,14 @@ static ptr s_set_code_long(p, n, x) ptr p, n, x; { static void s_set_code_long2(p, n, h, l) ptr p, n, h, l; { I32 *a; - a = (I32 *)((uptr)p + UNFIX(n)); + a = (I32 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = (I32)((UNFIX(h) << 16) + UNFIX(l)); } static ptr s_set_code_quad(p, n, x) ptr p, n, x; { I64 *a; - a = (I64 *)((uptr)p + UNFIX(n)); + a = (I64 *)TO_VOIDP((uptr)p + UNFIX(n)); *a = Sfixnump(x) ? UNFIX(x) : S_int64_value("\\#set-code-quad!", x); return Svoid; } @@ -1535,22 +1535,37 @@ static ptr s_profile_release_counters(void) { void S_dump_tc(ptr tc) { INT i; - printf("AC0=%p AC1=%p SFP=%p CP=%p\n", AC0(tc), AC1(tc), SFP(tc), CP(tc)); - printf("ESP=%p AP=%p EAP=%p\n", ESP(tc), AP(tc), EAP(tc)); - printf("TRAP=%p XP=%p YP=%p REAL_EAP=%p\n", TRAP(tc), XP(tc), YP(tc), REAL_EAP(tc)); - printf("CCHAIN=%p RANDOMSEED=%ld SCHEMESTACK=%p STACKCACHE=%p\n", CCHAIN(tc), (long)RANDOMSEED(tc), SCHEMESTACK(tc), STACKCACHE(tc)); - printf("STACKLINK=%p SCHEMESTACKSIZE=%ld WINDERS=%p U=%p\n", STACKLINK(tc), (long)SCHEMESTACKSIZE(tc), WINDERS(tc), U(tc)); - printf("V=%p W=%p X=%p Y=%p\n", V(tc), W(tc), X(tc), Y(tc)); - printf("SOMETHING=%p KBDPEND=%p SIGPEND=%p TIMERTICKS=%p\n", SOMETHINGPENDING(tc), KEYBOARDINTERRUPTPENDING(tc), SIGNALINTERRUPTPENDING(tc), TIMERTICKS(tc)); - printf("DISABLECOUNT=%p PARAMETERS=%p\n", DISABLECOUNT(tc), PARAMETERS(tc)); + printf("AC0=%p AC1=%p SFP=%p CP=%p\n", TO_VOIDP(AC0(tc)), TO_VOIDP(AC1(tc)), TO_VOIDP(SFP(tc)), TO_VOIDP(CP(tc))); + printf("ESP=%p AP=%p EAP=%p\n", TO_VOIDP(ESP(tc)), TO_VOIDP(AP(tc)), TO_VOIDP(EAP(tc))); + printf("TRAP=%p XP=%p YP=%p REAL_EAP=%p\n", TO_VOIDP(TRAP(tc)), TO_VOIDP(XP(tc)), TO_VOIDP(YP(tc)), TO_VOIDP(REAL_EAP(tc))); + printf("CCHAIN=%p RANDOMSEED=%ld SCHEMESTACK=%p STACKCACHE=%p\n", TO_VOIDP(CCHAIN(tc)), (long)RANDOMSEED(tc), + TO_VOIDP(SCHEMESTACK(tc)), TO_VOIDP(STACKCACHE(tc))); + printf("STACKLINK=%p SCHEMESTACKSIZE=%ld WINDERS=%p U=%p\n", TO_VOIDP(STACKLINK(tc)), (long)SCHEMESTACKSIZE(tc), TO_VOIDP(WINDERS(tc)), TO_VOIDP(U(tc))); + printf("V=%p W=%p X=%p Y=%p\n", TO_VOIDP(V(tc)), TO_VOIDP(W(tc)), TO_VOIDP(X(tc)), TO_VOIDP(Y(tc))); + printf("SOMETHING=%p KBDPEND=%p SIGPEND=%p TIMERTICKS=%p\n", TO_VOIDP(SOMETHINGPENDING(tc)), TO_VOIDP(KEYBOARDINTERRUPTPENDING(tc)), + TO_VOIDP(SIGNALINTERRUPTPENDING(tc)), TO_VOIDP(TIMERTICKS(tc))); + printf("DISABLECOUNT=%p PARAMETERS=%p\n", TO_VOIDP(DISABLECOUNT(tc)), TO_VOIDP(PARAMETERS(tc))); for (i = 0 ; i < virtual_register_count ; i += 1) { - printf("VIRTREG[%d]=%p", i, VIRTREG(tc, i)); + printf("VIRTREG[%d]=%p", i, TO_VOIDP(VIRTREG(tc, i))); if ((i & 0x11) == 0x11 || i == virtual_register_count - 1) printf("\n"); } fflush(stdout); } -#define proc2ptr(x) (ptr)(iptr)(x) +static IBOOL s_native_little_endian() { +#define big 0 +#define little 1 +#ifdef PORTABLE_BYTECODE +# ifdef PORTABLE_BYTECODE_BIGENDIAN +# define unknown big +# else +# define unknown little +# endif +#endif + return native_endianness == little; +} + +#define proc2ptr(x) TO_PTR(x) void S_prim5_init() { if (!S_boot_time) return; @@ -1662,6 +1677,8 @@ void S_prim5_init() { Sforeign_symbol("(cs)phantom_bytevector_adjust", (void*)S_phantom_bytevector_adjust); + Sforeign_symbol("(cs)native_little_endian", (void *)s_native_little_endian); + Sforeign_symbol("(cs)logand", (void *)S_logand); Sforeign_symbol("(cs)logbitp", (void *)S_logbitp); Sforeign_symbol("(cs)logbit0", (void *)S_logbit0); @@ -1835,8 +1852,8 @@ static ptr s_get_reloc(co, with_offsets) ptr co; IBOOL with_offsets; { } static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt) { - void *srcaddr = (void *)((iptr)src + srcoff); - void *dstaddr = (void *)((iptr)dst + dstoff); + void *srcaddr = TO_VOIDP((iptr)src + srcoff); + void *dstaddr = TO_VOIDP((iptr)dst + dstoff); if (dst != src) memcpy(dstaddr, srcaddr, cnt); else @@ -1844,8 +1861,8 @@ static void s_byte_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt) { } static void s_ptr_copy(ptr src, iptr srcoff, ptr dst, iptr dstoff, iptr cnt) { - void *srcaddr = (void *)((iptr)src + srcoff); - void *dstaddr = (void *)((iptr)dst + dstoff); + void *srcaddr = TO_VOIDP((iptr)src + srcoff); + void *dstaddr = TO_VOIDP((iptr)dst + dstoff); cnt = cnt << log2_ptr_bytes; if (dst != src) memcpy(dstaddr, srcaddr, cnt); @@ -1994,11 +2011,11 @@ static uptr s_malloc(iptr n) { else S_error("foreign-alloc", "malloc failed"); } - return (uptr)p; + return (uptr)TO_PTR(p); } static void s_free(uptr addr) { - free((void *)addr); + free(TO_VOIDP(addr)); } #ifdef FEATURE_ICONV @@ -2086,7 +2103,7 @@ static ptr s_iconv_from_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr size_t inbytesleft, outbytesleft; uptr inmax, k, new_i, new_o; - outbuf = (char *)&BVIT(out, o); + outbuf = TO_VOIDP(&BVIT(out, o)); outbytesleft = oend - o; inmax = iend - i; @@ -2122,7 +2139,7 @@ static ptr s_iconv_to_string(uptr cd, ptr in, uptr i, uptr iend, ptr out, uptr o size_t inbytesleft, outbytesleft; uptr outmax, k, new_i, new_o; - inbuf = (char *)&BVIT(in, i); + inbuf = TO_VOIDP(&BVIT(in, i)); inbytesleft = iend - i; outmax = oend - o; diff --git a/c/random.c b/c/random.c index c7d80a718d..f1a1e15079 100644 --- a/c/random.c +++ b/c/random.c @@ -22,7 +22,7 @@ /* Representation is arecord with 6 `double` fields: */ -#define RECORDINSTDBLA(x) ((double *)((uptr)&RECORDINSTIT(x, 0) + (max_float_alignment - ptr_bytes))) +#define RECORDINSTDBLA(x) ((double *)TO_VOIDP((uptr)TO_PTR(&RECORDINSTIT(x, 0)) + (max_float_alignment - ptr_bytes))) #define RANDSTATEX10(x) (RECORDINSTDBLA(x)[0]) #define RANDSTATEX11(x) (RECORDINSTDBLA(x)[1]) diff --git a/c/scheme.c b/c/scheme.c index d204edc028..4aaa83d6f8 100644 --- a/c/scheme.c +++ b/c/scheme.c @@ -121,10 +121,10 @@ static void main_init() { CODEFREE(p) = 0; CODEINFO(p) = Sfalse; CODEPINFOS(p) = Snil; - RPHEADERFRAMESIZE(&CODEIT(p, 0)) = 0; - RPHEADERLIVEMASK(&CODEIT(p, 0)) = 0; - RPHEADERTOPLINK(&CODEIT(p, 0)) = - (uptr)&RPHEADERTOPLINK(&CODEIT(p, 0)) - (uptr)p; + RPHEADERFRAMESIZE(TO_PTR(&CODEIT(p, 0))) = 0; + RPHEADERLIVEMASK(TO_PTR(&CODEIT(p, 0))) = 0; + RPHEADERTOPLINK(TO_PTR(&CODEIT(p, 0))) = + (uptr)TO_PTR(&RPHEADERTOPLINK(TO_PTR(&CODEIT(p, 0)))) - (uptr)p; S_protect(&S_G.dummy_code_object); S_G.dummy_code_object = p; @@ -184,6 +184,7 @@ static void idiot_checks() { (long)sizeof(short), short_bits); oops = 1; } +#ifndef PORTABLE_BYTECODE if (sizeof(long) * 8 != long_bits) { fprintf(stderr, "sizeof(long) * 8 [%ld] != long_bits [%d]\n", (long)sizeof(long), long_bits); @@ -195,12 +196,14 @@ static void idiot_checks() { (long)sizeof(long long), long_long_bits); oops = 1; } +#endif #endif if (sizeof(wchar_t) * 8 != wchar_bits) { fprintf(stderr, "sizeof(wchar_t) * 8 [%ld] != wchar_bits [%d]\n", (long)sizeof(wchar_t), wchar_bits); oops = 1; } +#ifndef PORTABLE_BYTECODE if (sizeof(size_t) * 8 != size_t_bits) { fprintf(stderr, "sizeof(size_t) * 8 [%ld] != size_t_bits [%d]\n", (long)sizeof(size_t), size_t_bits); @@ -223,6 +226,7 @@ static void idiot_checks() { (long)sizeof(time_t), time_t_bits); oops = 1; } +#endif if (sizeof(bigit) * 8 != bigit_bits) { fprintf(stderr, "sizeof(bigit) * 8 [%ld] != bigit_bits [%d]\n", (long)sizeof(bigit), bigit_bits); @@ -287,6 +291,7 @@ static void idiot_checks() { } #define big 0 #define little 1 +#define unknown 2 if (native_endianness == big) { uptr x[1]; *x = 1; @@ -294,7 +299,7 @@ static void idiot_checks() { fprintf(stderr, "endianness claimed to be big, appears to be little\n"); oops = 1; } - } else { + } else if (native_endianness == little) { uptr x[1]; *x = 1; if (*(char *)x == 0) { @@ -314,7 +319,7 @@ static void idiot_checks() { fprintf(stderr, "cards_per_segment is not a multiple of sizeof(iptr)\n"); oops = 1; } - if (((uptr)(&((seginfo *)0)->dirty_bytes[0]) & (sizeof(iptr) - 1)) != 0) { + if (((uptr)TO_PTR(&((seginfo *)0)->dirty_bytes[0]) & (sizeof(iptr) - 1)) != 0) { /* gc sometimes processes dirty bytes sizeof(iptr) bytes at a time */ fprintf(stderr, "dirty_bytes[0] is not iptr-aligned wrt to seginfo struct\n"); oops = 1; @@ -365,14 +370,16 @@ static void check_ap(tc) ptr tc; { (void) fprintf(stderr, "ap is not double word aligned\n"); S_abnormal_exit(); } - if ((ptr *)AP(tc) > (ptr *)EAP(tc)) { + if ((uptr)AP(tc) > (uptr)EAP(tc)) { (void) fprintf(stderr, "ap is greater than eap\n"); S_abnormal_exit(); } } void S_generic_invoke(tc, code) ptr tc; ptr code; { -#if defined(PPCAIX) +#if defined(PORTABLE_BYTECODE) + S_pb_interp(tc, (void *)&CODEIT(code,0)); +#elif defined(PPCAIX) struct {caddr_t entry, toc, static_link;} hdr; hdr.entry = (caddr_t)&CODEIT(code,0); hdr.toc = (caddr_t)0; diff --git a/c/schlib.c b/c/schlib.c index 772e95487b..243e1f6233 100644 --- a/c/schlib.c +++ b/c/schlib.c @@ -174,11 +174,11 @@ void Sinitframe(n) iptr n; { void S_initframe(tc, n) ptr tc; iptr n; { /* check for and handle stack overflow */ - if ((ptr *)SFP(tc) + n + 2 > (ptr *)ESP(tc)) + if ((ptr *)TO_VOIDP(SFP(tc)) + n + 2 > (ptr *)TO_VOIDP(ESP(tc))) S_overflow(tc, (n+2)*sizeof(ptr)); /* intermediate frame contains old RA + cchain */; - SFP(tc) = (ptr)((ptr *)SFP(tc) + 2); + SFP(tc) = TO_PTR((ptr *)TO_VOIDP(SFP(tc)) + 2); } void Sput_arg(i, x) iptr i; ptr x; { @@ -229,9 +229,9 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t /* Lock a code object passed in TS, which is a more immediate caller whose return address is on the C stack */ S_immobilize_object(TS(tc)); - CCHAIN(tc) = Scons(Scons(jb, Scons(code,TS(tc))), CCHAIN(tc)); + CCHAIN(tc) = Scons(Scons(TO_PTR(jb), Scons(code,TS(tc))), CCHAIN(tc)); } else { - CCHAIN(tc) = Scons(Scons(jb, Scons(code,Sfalse)), CCHAIN(tc)); + CCHAIN(tc) = Scons(Scons(TO_PTR(jb), Scons(code,Sfalse)), CCHAIN(tc)); } FRAME(tc, -1) = CCHAIN(tc); @@ -247,7 +247,7 @@ void S_call_help(tc_in, singlep, lock_ts) ptr tc_in; IBOOL singlep; IBOOL lock_t break; case 1: { /* normal return */ ptr yp = CCHAIN(tc); - FREEJMPBUF(CAAR(yp)); + FREEJMPBUF(TO_VOIDP(CAAR(yp))); CCHAIN(tc) = Scdr(yp); break; } @@ -282,7 +282,7 @@ void S_return() { ptr tc = get_thread_context(); ptr xp, yp; - SFP(tc) = (ptr)((ptr *)SFP(tc) - 2); + SFP(tc) = TO_PTR((ptr *)TO_VOIDP(SFP(tc)) - 2); /* grab saved cchain */ yp = FRAME(tc, 1); @@ -298,10 +298,10 @@ void S_return() { S_mobilize_object(Scar(p)); if (Scdr(p) != Sfalse) S_mobilize_object(Scdr(p)); if (xp == yp) break; - FREEJMPBUF(CAAR(xp)); + FREEJMPBUF(TO_VOIDP(CAAR(xp))); } /* reset cchain and return via longjmp */ CCHAIN(tc) = yp; - LONGJMP(CAAR(yp), 1); + LONGJMP(TO_VOIDP(CAAR(yp)), 1); } diff --git a/c/schsig.c b/c/schsig.c index d5a92061c2..8cd469f565 100644 --- a/c/schsig.c +++ b/c/schsig.c @@ -52,7 +52,7 @@ static void split(k, s) ptr k; ptr *s; { tc_mutex_acquire() /* set m to size of lower piece, n to size of upper piece */ - m = (uptr)s - (uptr)CONTSTACK(k); + m = (uptr)TO_PTR(s) - (uptr)CONTSTACK(k); n = CONTCLENGTH(k) - m; si = SegInfo(ptr_get_segment(k)); @@ -67,8 +67,8 @@ static void split(k, s) ptr k; ptr *s; { Snil, Sfalse); CONTLENGTH(k) = CONTCLENGTH(k) = n; - CONTSTACK(k) = (ptr)s; - *s = (ptr)DOUNDERFLOW; + CONTSTACK(k) = TO_PTR(s); + *s = TO_PTR(DOUNDERFLOW); tc_mutex_release() } @@ -91,14 +91,14 @@ void S_split_and_resize() { iptr frame_size; ptr *front_stack_ptr, *end_stack_ptr, *split_point, *guard; - front_stack_ptr = (ptr *)CONTSTACK(k); - end_stack_ptr = (ptr *)((uptr)front_stack_ptr + CONTCLENGTH(k)); + front_stack_ptr = TO_VOIDP(CONTSTACK(k)); + end_stack_ptr = TO_VOIDP((uptr)TO_PTR(front_stack_ptr) + CONTCLENGTH(k)); - guard = (ptr *)((uptr)end_stack_ptr - underflow_limit); + guard = TO_VOIDP((uptr)TO_PTR(end_stack_ptr) - underflow_limit); /* set split point to base of top frame */ frame_size = ENTRYFRAMESIZE(CONTRET(k)); - split_point = (ptr *)((uptr)end_stack_ptr - frame_size); + split_point = TO_VOIDP((uptr)TO_PTR(end_stack_ptr) - frame_size); /* split only if we have more than one frame */ if (split_point != front_stack_ptr) { @@ -107,7 +107,7 @@ void S_split_and_resize() { for (;;) { ptr *p; frame_size = ENTRYFRAMESIZE(*split_point); - p = (ptr *)((uptr)split_point - frame_size); + p = TO_VOIDP((uptr)TO_PTR(split_point) - frame_size); if (p < guard) break; split_point = p; } @@ -138,11 +138,11 @@ iptr S_continuation_depth(k) ptr k; { n = 0; /* terminate on shot 1-shot, which could be null_continuation */ while (CONTLENGTH(k) != scaled_shot_1_shot_flag) { - stack_base = (ptr *)CONTSTACK(k); + stack_base = TO_VOIDP(CONTSTACK(k)); frame_size = ENTRYFRAMESIZE(CONTRET(k)); - stack_ptr = (ptr *)((uptr)stack_base + CONTCLENGTH(k)); + stack_ptr = TO_VOIDP((uptr)TO_PTR(stack_base) + CONTCLENGTH(k)); for (;;) { - stack_ptr = (ptr *)((uptr)stack_ptr - frame_size); + stack_ptr = TO_VOIDP((uptr)TO_PTR(stack_ptr) - frame_size); n += 1; if (stack_ptr == stack_base) break; frame_size = ENTRYFRAMESIZE(*stack_ptr); @@ -157,8 +157,8 @@ ptr S_single_continuation(k, n) ptr k; iptr n; { /* bug out on shot 1-shots, which could be null_continuation */ while (CONTLENGTH(k) != scaled_shot_1_shot_flag) { - stack_base = (ptr *)CONTSTACK(k); - stack_top = (ptr *)((uptr)stack_base + CONTCLENGTH(k)); + stack_base = TO_VOIDP(CONTSTACK(k)); + stack_top = TO_VOIDP((uptr)TO_PTR(stack_base) + CONTCLENGTH(k)); stack_ptr = stack_top; frame_size = ENTRYFRAMESIZE(CONTRET(k)); for (;;) { @@ -172,14 +172,14 @@ ptr S_single_continuation(k, n) ptr k; iptr n; { k = CONTLINK(k); } - stack_ptr = (ptr *)((uptr)stack_ptr - frame_size); + stack_ptr = TO_VOIDP((uptr)TO_PTR(stack_ptr) - frame_size); if (stack_ptr != stack_base) split(k, stack_ptr); return k; } else { n -= 1; - stack_ptr = (ptr *)((uptr)stack_ptr - frame_size); + stack_ptr = TO_VOIDP((uptr)TO_PTR(stack_ptr) - frame_size); if (stack_ptr == stack_base) break; frame_size = ENTRYFRAMESIZE(*stack_ptr); } @@ -201,7 +201,7 @@ void S_handle_overflood() { ptr tc = get_thread_context(); /* xp points to where esp needs to be */ - S_overflow(tc, ((ptr *)XP(tc) - (ptr *)SFP(tc))*sizeof(ptr)); + S_overflow(tc, ((ptr *)TO_VOIDP(XP(tc)) - (ptr *)TO_VOIDP(SFP(tc)))*sizeof(ptr)); } void S_handle_apply_overflood() { @@ -227,39 +227,39 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; { iptr split_stack_length, split_stack_clength; ptr nuate; - sfp = (ptr *)SFP(tc); + sfp = TO_VOIDP(SFP(tc)); nuate = SYMVAL(S_G.nuate_id); if (!Scodep(nuate)) { S_error_abort("overflow: nuate not yet defined"); } - guard = (ptr *)((uptr)sfp - underflow_limit); + guard = TO_VOIDP((uptr)TO_PTR(sfp) - underflow_limit); /* leave at least stack_slop headroom in the old stack to reduce the need for return-point overflow checks */ - other_guard = (ptr *)((uptr)SCHEMESTACK(tc) + (uptr)SCHEMESTACKSIZE(tc) - (uptr)stack_slop); - if ((uptr)other_guard < (uptr)guard) guard = other_guard; + other_guard = TO_VOIDP((uptr)SCHEMESTACK(tc) + (uptr)SCHEMESTACKSIZE(tc) - (uptr)TO_PTR(stack_slop)); + if ((uptr)TO_PTR(other_guard) < (uptr)TO_PTR(guard)) guard = other_guard; /* split only if old stack contains more than underflow_limit bytes */ - if (guard > (ptr *)SCHEMESTACK(tc)) { + if (guard > (ptr *)TO_VOIDP(SCHEMESTACK(tc))) { iptr frame_size; /* set split point to base of the frame below the current one */ frame_size = ENTRYFRAMESIZE(*sfp); - split_point = (ptr *)((uptr)sfp - frame_size); + split_point = TO_VOIDP((uptr)TO_PTR(sfp) - frame_size); /* split only if we have more than one frame */ - if (split_point != (ptr *)SCHEMESTACK(tc)) { + if (split_point != TO_VOIDP(SCHEMESTACK(tc))) { /* walk the stack to set split_point at first frame above guard */ /* note that first frame may have put us below the guard already */ for (;;) { ptr *p; frame_size = ENTRYFRAMESIZE(*split_point); - p = (ptr *)((uptr)split_point - frame_size); + p = TO_VOIDP((uptr)TO_PTR(split_point) - frame_size); if (p < guard) break; split_point = p; } - split_stack_clength = (uptr)split_point - (uptr)SCHEMESTACK(tc); + split_stack_clength = (uptr)TO_PTR(split_point) - (uptr)SCHEMESTACK(tc); /* promote to multi-shot if current stack is shrimpy */ if (SCHEMESTACKSIZE(tc) < default_stack_size / 4) { @@ -284,16 +284,16 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; { tc_mutex_release() /* overwrite old return address with dounderflow */ - *split_point = (ptr)DOUNDERFLOW; + *split_point = TO_PTR(DOUNDERFLOW); } } else { - split_point = (ptr *)SCHEMESTACK(tc); + split_point = TO_VOIDP(SCHEMESTACK(tc)); } - above_split_size = SCHEMESTACKSIZE(tc) - ((uptr)split_point - (uptr)SCHEMESTACK(tc)); + above_split_size = SCHEMESTACKSIZE(tc) - ((uptr)TO_PTR(split_point) - (uptr)SCHEMESTACK(tc)); /* allocate a new stack, retaining same relative sfp */ - sfp_offset = (uptr)sfp - (uptr)split_point; + sfp_offset = (uptr)TO_PTR(sfp) - (uptr)TO_PTR(split_point); tc_mutex_acquire() S_reset_scheme_stack(tc, above_split_size + frame_request); tc_mutex_release() @@ -302,7 +302,7 @@ void S_overflow(tc, frame_request) ptr tc; iptr frame_request; { /* copy up everything above the split point. we don't know where the current frame ends, so we copy through the end of the old stack */ {ptr *p, *q; iptr n; - p = (ptr *)SCHEMESTACK(tc); + p = TO_VOIDP(SCHEMESTACK(tc)); q = split_point; for (n = above_split_size; n != 0; n -= sizeof(ptr)) *p++ = *q++; } @@ -325,10 +325,10 @@ static void reset_scheme() { tc_mutex_acquire() /* eap should always be up-to-date now that we write-through to the tc when making any changes to eap when eap is a real register */ - S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc)); + S_scan_dirty(TO_VOIDP(EAP(tc)), TO_VOIDP(REAL_EAP(tc))); S_reset_allocation_pointer(tc); S_reset_scheme_stack(tc, stack_slop); - FRAME(tc,0) = (ptr)DOUNDERFLOW; + FRAME(tc,0) = TO_PTR(DOUNDERFLOW); tc_mutex_release() } @@ -399,7 +399,7 @@ static void do_error(type, who, s, args) iptr type; const char *who, *s; ptr arg AC0(tc) = (ptr)1; CP(tc) = S_symbol_value(S_G.error_id); S_put_scheme_arg(tc, 1, args); - LONGJMP(CAAR(CCHAIN(tc)), -1); + LONGJMP(TO_VOIDP(CAAR(CCHAIN(tc))), -1); } static void handle_call_error(tc, type, x) ptr tc; iptr type; ptr x; { @@ -607,7 +607,7 @@ struct signal_queue { }; static IBOOL enqueue_scheme_signal(ptr tc, INT sig) { - struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc)); + struct signal_queue *queue = TO_VOIDP(SIGNALINTERRUPTQUEUE(tc)); /* ignore the signal if we failed to allocate the queue */ if (queue == NULL) return 0; INT tail = queue->tail; @@ -622,7 +622,7 @@ static IBOOL enqueue_scheme_signal(ptr tc, INT sig) { ptr S_dequeue_scheme_signals(ptr tc) { ptr ls = Snil; - struct signal_queue *queue = (struct signal_queue *)(SIGNALINTERRUPTQUEUE(tc)); + struct signal_queue *queue = TO_VOIDP(SIGNALINTERRUPTQUEUE(tc)); if (queue == NULL) return ls; INT head = queue->head; INT tail = queue->tail; @@ -652,7 +652,7 @@ static ptr allocate_scheme_signal_queue() { if (queue != (struct signal_queue *)0) { queue->head = queue->tail = 0; } - return (ptr)queue; + return TO_PTR(queue); } ptr S_allocate_scheme_signal_queue() { @@ -686,7 +686,7 @@ static void handle_signal(INT sig, UNUSED siginfo_t *si, UNUSED void *data) { ptr tc = get_thread_context(); /* disable keyboard interrupts in subordinate threads until we think of something more clever to do with them */ - if (tc == S_G.thread_context) { + if (tc == TO_PTR(&S_G.thread_context)) { if (!S_pants_down && Sboolean_value(KEYBOARDINTERRUPTPENDING(tc))) { /* this is a no-no, but the only other options are to ignore the signal or to kill the process */ diff --git a/c/segment.c b/c/segment.c index f77c8ba93e..c1c90263a6 100644 --- a/c/segment.c +++ b/c/segment.c @@ -59,12 +59,14 @@ void S_segment_init() { S_G.number_of_nonstatic_segments = 0; S_G.number_of_empty_segments = 0; +#ifndef PORTABLE_BYTECODE if (seginfo_space_disp != offsetof(seginfo, space)) S_error_abort("seginfo_space_disp is wrong"); if (seginfo_generation_disp != offsetof(seginfo, generation)) S_error_abort("seginfo_generation_disp is wrong"); if (seginfo_list_bits_disp != offsetof(seginfo, list_bits)) S_error_abort("seginfo_list_bits_disp is wrong"); +#endif } static uptr membytes = 0; @@ -362,11 +364,11 @@ static seginfo *allocate_segments(nreq) uptr nreq; { addr = S_getmem(bytes, 0); debug(printf("allocate_segments addr = %p\n", addr)) - base = addr_get_segment((uptr)addr + bytes_per_segment - 1); + base = addr_get_segment((uptr)TO_PTR(addr) + bytes_per_segment - 1); /* if the base of the first segment is the same as the base of the chunk, and the last segment isn't the last segment in memory (which could cause 'next' and 'end' pointers to wrap), we've actually got nact + 1 usable segments in this chunk */ - if (build_ptr(base, 0) == addr && base + nact != ((uptr)1 << (ptr_bits - segment_offset_bits)) - 1) + if (build_ptr(base, 0) == TO_PTR(addr) && base + nact != ((uptr)1 << (ptr_bits - segment_offset_bits)) - 1) nact += 1; chunk = S_getmem(sizeof(chunkinfo) + sizeof(seginfo) * nact, 0); diff --git a/c/segment.h b/c/segment.h index 361e083cc6..a9961f3a97 100644 --- a/c/segment.h +++ b/c/segment.h @@ -25,14 +25,14 @@ /* segment_info */ -#define SEGMENT_T1_SIZE (1<>segment_t1_bits)&(SEGMENT_T2_SIZE-1)) -#define SEGMENT_T3_SIZE (1<>(segment_t2_bits+segment_t1_bits)) FORCEINLINE seginfo *SegInfo(uptr i) { @@ -49,7 +49,7 @@ FORCEINLINE seginfo *MaybeSegInfo(uptr i) { #else /* segment_t3_bits */ #ifdef segment_t2_bits -#define SEGMENT_T2_SIZE (1<>segment_t1_bits) #define SEGMENT_T3_SIZE 0 diff --git a/c/thread.c b/c/thread.c index ffd6ca1b55..7162cf0849 100644 --- a/c/thread.c +++ b/c/thread.c @@ -55,17 +55,17 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { tc_mutex_acquire() if (S_threads == Snil) { - tc = (ptr)S_G.thread_context; + tc = TO_PTR(S_G.thread_context); } else { /* clone parent */ ptr p_v = PARAMETERS(p_tc); iptr i, n = Svector_length(p_v); /* use S_vector_in to avoid thread-local allocation */ ptr v = S_vector_in(space_new, 0, n); - tc = (ptr)malloc(size_tc); + tc = TO_PTR(malloc(size_tc)); if (tc == (ptr)0) S_error(who, "unable to malloc thread data structure"); - memcpy((void *)tc, (void *)p_tc, size_tc); + memcpy(TO_VOIDP(tc), TO_VOIDP(p_tc), size_tc); for (i = 0; i < n; i += 1) INITVECTIT(v, i) = Svector_ref(p_v, i); @@ -88,7 +88,7 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { /* S_reset_scheme_stack initializes stack, size, esp, and sfp */ S_reset_scheme_stack(tc, stack_slop); - FRAME(tc,0) = (ptr)&CODEIT(S_G.dummy_code_object,size_rp_header); + FRAME(tc,0) = TO_PTR(&CODEIT(S_G.dummy_code_object,size_rp_header)); /* S_reset_allocation_pointer initializes ap and eap */ S_reset_allocation_pointer(tc); @@ -127,7 +127,7 @@ ptr S_create_thread_object(who, p_tc) const char *who; ptr p_tc; { GUARDIANENTRIES(tc) = Snil; - LZ4OUTBUFFER(tc) = NULL; + LZ4OUTBUFFER(tc) = 0; tc_mutex_release() @@ -205,7 +205,7 @@ static IBOOL destroy_thread(tc) ptr tc; { S_nthreads -= 1; /* process remembered set before dropping allocation area */ - S_scan_dirty((ptr **)EAP(tc), (ptr **)REAL_EAP(tc)); + S_scan_dirty((ptr *)EAP(tc), (ptr *)REAL_EAP(tc)); /* process guardian entries */ { diff --git a/c/types.h b/c/types.h index 0172681629..fc2197ebf3 100644 --- a/c/types.h +++ b/c/types.h @@ -74,35 +74,44 @@ typedef int IFASLCODE; /* fasl type codes */ #define SBUFSIZ BUFSIZ #endif +#define ALREADY_PTR(p) (p) + /* inline allocation --- mutex required */ /* find room allocates n bytes in space s and generation g into * destination x, tagged with ty, punting to find_more_room if * no space is left in the current segment. n is assumed to be * an integral multiple of the object alignment. */ -#define find_room(s, g, t, n, x) {\ +#define find_room_T(s, g, t, n, T, x) { \ ptr X = S_G.next_loc[s][g];\ S_G.next_loc[s][g] = (ptr)((uptr)X + (n));\ if ((S_G.bytes_left[s][g] -= (n)) < 0) X = S_find_more_room(s, g, n, X);\ - (x) = TYPE(X, t);\ + (x) = T(TYPE(X, t)); \ } +#define find_room(s, g, t, n, x) find_room_T(s, g, t, n, ALREADY_PTR, x) +#define find_room_voidp(s, g, n, x) find_room_T(s, g, typemod, n, TO_VOIDP, x) + /* thread-local inline allocation --- no mutex required */ /* thread_find_room allocates n bytes in the local allocation area of * the thread (hence space new, generation zero) into destination x, tagged * with type t, punting to find_more_room if no space is left in the current * allocation area. n is assumed to be an integral multiple of the object * alignment. */ -#define thread_find_room(tc, t, n, x) {\ +#define thread_find_room_T(tc, t, n, T, x) { \ ptr _tc = tc;\ uptr _ap = (uptr)AP(_tc);\ if ((uptr)n > ((uptr)EAP(_tc) - _ap)) {\ - (x) = S_get_more_room_help(_tc, _ap, t, n);\ + ptr _hp = S_get_more_room_help(_tc, _ap, t, n); \ + (x) = T(_hp); \ } else {\ - (x) = TYPE(_ap,t);\ + (x) = T(TYPE(_ap,t)); \ AP(_tc) = (ptr)(_ap + n);\ }\ } +#define thread_find_room(tc, t, n, x) thread_find_room_T(tc, t, n, ALREADY_PTR, x) +#define thread_find_room_voidp(tc, n, x) thread_find_room_T(tc, typemod, n, TO_VOIDP, x) + #ifndef NO_PRESERVE_FLONUM_EQ # define PRESERVE_FLONUM_EQ #endif @@ -154,7 +163,13 @@ typedef struct _seginfo { #endif octet *counting_mask; /* bitmap of counting roots during a GC */ octet *measured_mask; /* bitmap of objects that have been measured */ +#ifdef PORTABLE_BYTECODE + union { ptr force_alignment; +#endif octet dirty_bytes[cards_per_segment]; /* one dirty byte per card */ +#ifdef PORTABLE_BYTECODE + }; +#endif } seginfo; typedef struct _chunkinfo { @@ -259,7 +274,7 @@ typedef struct _bucket_pointer_list { #define UNTYPE(x,type) ((ptr)((iptr)(x) + typemod - (type))) #define UNTYPE_ANY(x) ((ptr)(((iptr)(x) + (typemod - 1)) & ~(typemod - 1))) #define TYPEBITS(x) ((iptr)(x) & (typemod - 1)) -#define TYPEFIELD(x) (*(ptr *)UNTYPE(x, type_typed_object)) +#define TYPEFIELD(x) (*(ptr *)TO_VOIDP(UNTYPE(x, type_typed_object))) #define FIX(x) Sfixnum(x) #define UNFIX(x) Sfixnum_value(x) @@ -316,7 +331,7 @@ typedef struct _bucket_pointer_list { #define LIST4(x,y,z,w) Scons(x, LIST3(y, z, w)) #define REGARG(tc,i) ARGREG(tc,(i)-1) -#define FRAME(tc,i) (((ptr *)SFP(tc))[i]) +#define FRAME(tc,i) (((ptr *)TO_VOIDP(SFP(tc)))[i]) #ifdef PTHREADS typedef struct { @@ -376,7 +391,7 @@ typedef struct { S_mutex_release(&S_tc_mutex);\ } #else -#define get_thread_context() (ptr)S_G.thread_context +#define get_thread_context() TO_PTR(S_G.thread_context) #define deactivate_thread(tc) {} #define reactivate_thread(tc) {} #define tc_mutex_acquire() {} @@ -412,9 +427,9 @@ typedef struct { #define MAKE_FD(fd) Sinteger(fd) #define GET_FD(file) ((INT)Sinteger_value(file)) -#define PTRFIELD(x,disp) (*(ptr *)((uptr)(x)+disp)) -#define INITPTRFIELD(x,disp) (*(ptr *)((uptr)(x)+disp)) -#define SETPTRFIELD(x,disp,y) DIRTYSET(((ptr *)((uptr)(x)+disp)),(y)) +#define PTRFIELD(x,disp) (*(ptr *)TO_VOIDP(((uptr)(x)+disp))) +#define INITPTRFIELD(x,disp) (*(ptr *)TO_VOIDP(((uptr)(x)+disp))) +#define SETPTRFIELD(x,disp,y) DIRTYSET(((ptr *)TO_VOIDP((uptr)(x)+disp)),(y)) #define INCRGEN(g) (g = g == S_G.max_nonstatic_generation ? static_generation : g+1) #define IMMEDIATE(x) (Sfixnump(x) || Simmediatep(x)) diff --git a/c/version.h b/c/version.h index 6bea3100c6..32c16fe4af 100644 --- a/c/version.h +++ b/c/version.h @@ -17,86 +17,95 @@ #include "config.h" #if (machine_type == machine_type_arm32le || machine_type == machine_type_tarm32le || machine_type == machine_type_arm64le || machine_type == machine_type_tarm64le) -#if (machine_type == machine_type_tarm32le || machine_type == machine_type_tarm64le) -#define PTHREADS -#endif -#define NOBLOCK O_NONBLOCK -#define LOAD_SHARED_OBJECT -#define USE_MMAP -#define MMAP_HEAP -#define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE -#define LDEXP -#define ARCHYPERBOLIC -#define GETPAGESIZE() getpagesize() -typedef char *memcpy_t; -#define MAKE_NAN(x) { x = 0.0; x = x / x; } -#define GETWD(x) getcwd((x),PATH_MAX) -typedef int tputsputcchar; -#define LOCKF -#define DIRMARKERP(c) ((c) == '/') -#define FLUSHCACHE -#ifndef DISABLE_X11 -#define LIBX11 "libX11.so" -#endif -#define LSEEK lseek64 -#define OFF_T off64_t -#define _LARGEFILE64_SOURCE -#define SECATIME(sb) (sb).st_atim.tv_sec -#define SECCTIME(sb) (sb).st_ctim.tv_sec -#define SECMTIME(sb) (sb).st_mtim.tv_sec -#define NSECATIME(sb) (sb).st_atim.tv_nsec -#define NSECCTIME(sb) (sb).st_ctim.tv_nsec -#define NSECMTIME(sb) (sb).st_mtim.tv_nsec -#define ICONV_INBUF_TYPE char ** -#define UNUSED __attribute__((__unused__)) +# define OS_ANY_LINUX +# if (machine_type == machine_type_tarm32le || machine_type == machine_type_tarm64le) +# define PTHREADS +# endif +# define OS_ANY_LINUX +# define LITTLE_ENDIAN_IEEE_DOUBLE +# define FLUSHCACHE #endif #if (machine_type == machine_type_ppc32le || machine_type == machine_type_tppc32le || machine_type == machine_type_ppc64le || machine_type == machine_type_tppc64le) -#if (machine_type == machine_type_tppc32le || machine_type == machine_type_tppc64le) -#define PTHREADS -#endif -#define NOBLOCK O_NONBLOCK -#define LOAD_SHARED_OBJECT -#define USE_MMAP -#define MMAP_HEAP -#define IEEE_DOUBLE -#define LDEXP -#define ARCHYPERBOLIC -#define GETPAGESIZE() getpagesize() -typedef char *memcpy_t; -#define MAKE_NAN(x) { x = 0.0; x = x / x; } -#define GETWD(x) getcwd((x),PATH_MAX) -typedef int tputsputcchar; -#define LOCKF -#define DIRMARKERP(c) ((c) == '/') -#define FLUSHCACHE -#ifndef DISABLE_X11 -#define LIBX11 "libX11.so" -#endif -#define LSEEK lseek64 -#define OFF_T off64_t -#define _LARGEFILE64_SOURCE -#define SECATIME(sb) (sb).st_atim.tv_sec -#define SECCTIME(sb) (sb).st_ctim.tv_sec -#define SECMTIME(sb) (sb).st_mtim.tv_sec -#define NSECATIME(sb) (sb).st_atim.tv_nsec -#define NSECCTIME(sb) (sb).st_ctim.tv_nsec -#define NSECMTIME(sb) (sb).st_mtim.tv_nsec -#define ICONV_INBUF_TYPE char ** -#define UNUSED __attribute__((__unused__)) +# define OS_ANY_LINUX +# if (machine_type == machine_type_tppc32le || machine_type == machine_type_tppc64le) +# define PTHREADS +# endif +# define FLUSHCACHE #endif #if (machine_type == machine_type_i3le || machine_type == machine_type_ti3le || machine_type == machine_type_a6le || machine_type == machine_type_ta6le) -#if (machine_type == machine_type_ti3le || machine_type == machine_type_ta6le) -#define PTHREADS +# define OS_ANY_LINUX +# if (machine_type == machine_type_ti3le || machine_type == machine_type_ta6le) +# define PTHREADS +# endif +# define LITTLE_ENDIAN_IEEE_DOUBLE #endif + +#if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb || machine_type == machine_type_a6fb || machine_type == machine_type_ta6fb) +# define OS_ANY_FREEBSD +# if (machine_type == machine_type_ti3fb || machine_type == machine_type_ta6fb) +# define PTHREADS +# endif +# define LITTLE_ENDIAN_IEEE_DOUBLE +#endif + +#if (machine_type == machine_type_i3nb || machine_type == machine_type_ti3nb || machine_type == machine_type_a6nb || machine_type == machine_type_ta6nb) +# define OS_ANY_NETBSD +# if (machine_type == machine_type_ti3nb || machine_type == machine_type_ta6nb) +# define PTHREADS +# endif +#endif + +#if (machine_type == machine_type_i3nt || machine_type == machine_type_ti3nt || machine_type == machine_type_a6nt || machine_type == machine_type_ta6nt) +# define OS_ANY_WINDOWS +# if (machine_type == machine_type_ti3nt || machine_type == machine_type_ta6nt) +# define PTHREADS +# endif +#endif + +#if (machine_type == machine_type_i3ob || machine_type == machine_type_ti3ob || machine_type == machine_type_a6ob || machine_type == machine_type_ta6ob) +# define OS_ANY_OPENBSD +# if (machine_type == machine_type_ti3ob || machine_type == machine_type_ta6ob) +# define PTHREADS +# endif +#endif + +#if (machine_type == machine_type_i3osx || machine_type == machine_type_ti3osx || machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx) +# define OS_ANY_MACOSX +# if (machine_type == machine_type_ti3osx || machine_type == machine_type_ta6osx) +# define PTHREADS +# endif +#endif + +#if (machine_type == machine_type_pb) +# if defined(__powerpc__) && !defined(__powerpc64__) +# define PORTABLE_BYTECODE_BIGENDIAN +# endif +# if defined(__linux__) +# define OS_ANY_LINUX +# ifndef PORTABLE_BYTECODE_BIGENDIAN +# define LITTLE_ENDIAN_IEEE_DOUBLE +# endif +# elif defined(__NetBSD__) +# define OS_ANY_NETBSD +# elif defined(__OpenBSD__) && !defined(__Bitrig__) +# define OS_ANY_OPENBSD +# elif defined(__FreeBSD__) || defined(__FreeBSD_kernel__) +# define OS_ANY_FREEBSD +# elif defined(_MSC_VER) || defined(__MINGW32__) +# define OS_ANY_WINDOWS +# elif __APPLE__ +# define OS_ANY_MACOSX +# endif +#endif + +#ifdef OS_ANY_LINUX #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE #define LDEXP #define ARCHYPERBOLIC #define GETPAGESIZE() getpagesize() @@ -107,7 +116,7 @@ typedef int tputsputcchar; #define LOCKF #define DIRMARKERP(c) ((c) == '/') #ifndef DISABLE_X11 -#define LIBX11 "libX11.so" +# define LIBX11 "libX11.so" #endif #define LSEEK lseek64 #define OFF_T off64_t @@ -122,16 +131,12 @@ typedef int tputsputcchar; #define UNUSED __attribute__((__unused__)) #endif -#if (machine_type == machine_type_i3fb || machine_type == machine_type_ti3fb || machine_type == machine_type_a6fb || machine_type == machine_type_ta6fb) -#if (machine_type == machine_type_ti3fb || machine_type == machine_type_ta6fb) -#define PTHREADS -#endif +#ifdef OS_ANY_FREEBSD #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP #define MMAP_HEAP #define IEEE_DOUBLE -#define LITTLE_ENDIAN_IEEE_DOUBLE #define LDEXP #define ARCHYPERBOLIC #define GETPAGESIZE() getpagesize() @@ -155,10 +160,9 @@ typedef int tputsputcchar; #define USE_OSSP_UUID #endif -#if (machine_type == machine_type_i3nb || machine_type == machine_type_ti3nb || machine_type == machine_type_a6nb || machine_type == machine_type_ta6nb) -#if (machine_type == machine_type_ti3nb || machine_type == machine_type_ta6nb) -#define NETBSD -#define PTHREADS +#ifdef OS_ANY_NETBSD +#ifdef PTHREADS +# define NETBSD #endif #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT @@ -191,10 +195,7 @@ typedef int tputsputcchar; #define USE_MBRTOWC_L #endif -#if (machine_type == machine_type_i3nt || machine_type == machine_type_ti3nt || machine_type == machine_type_a6nt || machine_type == machine_type_ta6nt) -#if (machine_type == machine_type_ti3nt || machine_type == machine_type_ta6nt) -#define PTHREADS -#endif +#ifdef OS_ANY_WINDOWS #define GETPAGESIZE() S_getpagesize() #define GETWD(x) GETCWD(x, _MAX_PATH) #define IEEE_DOUBLE @@ -257,10 +258,7 @@ struct timespec; #endif #endif -#if (machine_type == machine_type_i3ob || machine_type == machine_type_ti3ob || machine_type == machine_type_a6ob || machine_type == machine_type_ta6ob) -#if (machine_type == machine_type_ti3ob || machine_type == machine_type_ta6ob) -#define PTHREADS -#endif +#ifdef OS_ANY_OPENBSD #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP @@ -291,10 +289,7 @@ typedef int tputsputcchar; #define USE_OSSP_UUID #endif -#if (machine_type == machine_type_i3osx || machine_type == machine_type_ti3osx || machine_type == machine_type_a6osx || machine_type == machine_type_ta6osx) -#if (machine_type == machine_type_ti3osx || machine_type == machine_type_ta6osx) -#define PTHREADS -#endif +#ifdef OS_ANY_MACOSX #define MACOSX #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT @@ -326,9 +321,13 @@ typedef int tputsputcchar; #endif #if (machine_type == machine_type_i3qnx || machine_type == machine_type_ti3qnx) -#if (machine_type == machine_type_ti3qnx) -#define PTHREADS +# define OS_ANY_QNX +# if (machine_type == machine_type_ti3qnx) +# define PTHREADS +# endif #endif + +#ifdef OS_ANY_QNX #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP @@ -359,9 +358,13 @@ typedef int tputsputcchar; #endif #if (machine_type == machine_type_i3s2 || machine_type == machine_type_ti3s2 || machine_type == machine_type_a6s2 || machine_type == machine_type_ta6s2) -#if (machine_type == machine_type_ti3s2 || machine_type == machine_type_ta6s2) -#define PTHREADS +# define OS_ANY_SOLARIS2 +# if (machine_type == machine_type_ti3s2 || machine_type == machine_type_ta6s2) +# define PTHREADS +# endif #endif + +#ifdef OS_ANY_SOLARIS2 #define NOBLOCK O_NONBLOCK #define LOAD_SHARED_OBJECT #define USE_MMAP diff --git a/c/vfasl.c b/c/vfasl.c index 010aa7e98c..0d6fbdc502 100644 --- a/c/vfasl.c +++ b/c/vfasl.c @@ -195,8 +195,8 @@ static vfasl_hash_table *make_vfasl_hash_table(IBOOL permanent); static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value); static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key); -static ptr vfasl_malloc(uptr sz); -static ptr vfasl_calloc(uptr sz, uptr n); +static void *vfasl_malloc(uptr sz); +static void *vfasl_calloc(uptr sz, uptr n); static void sort_offsets(vfoff *p, vfoff len); @@ -242,10 +242,10 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) vspace_offsets[vspaces_count] = header.data_size; if (bv) { - ptr base_addr = &BVIT(bv, sizeof(vfasl_header) + offset); + void *base_addr = &BVIT(bv, sizeof(vfasl_header) + offset); thread_find_room(tc, typemod, header.data_size, data); - memcpy(data, base_addr, header.data_size); - table = ptr_add(base_addr, header.data_size); + memcpy(TO_VOIDP(data), base_addr, header.data_size); + table = ptr_add(TO_PTR(base_addr), header.data_size); } else { if (S_vfasl_boot_mode > 0) { for (s = 0; s < vspaces_count; s++) { @@ -256,7 +256,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) } else { find_room(vspace_spaces[s], static_generation, typemod, sz, vspaces[s]) } - if (S_fasl_stream_read(stream, vspaces[s], sz) < 0) + if (S_fasl_stream_read(stream, TO_VOIDP(vspaces[s]), sz) < 0) S_error("fasl-read", "input truncated"); } else vspaces[s] = (ptr)0; @@ -269,12 +269,12 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) to_static = 1; } else { thread_find_room(tc, typemod, header.data_size, data) - if (S_fasl_stream_read(stream, data, header.data_size) < 0) + if (S_fasl_stream_read(stream, TO_VOIDP(data), header.data_size) < 0) S_error("fasl-read", "input truncated"); } thread_find_room(tc, typemod, ptr_align(header.table_size), table) - if (S_fasl_stream_read(stream, table, header.table_size) < 0) + if (S_fasl_stream_read(stream, TO_VOIDP(table), header.table_size) < 0) S_error("fasl-read", "input truncated"); } @@ -284,11 +284,11 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) } else data = vspaces[0]; - symrefs = table; - rtdrefs = ptr_add(symrefs, header.symref_count * sizeof(vfoff)); - singletonrefs = ptr_add(rtdrefs, header.rtdref_count * sizeof(vfoff)); - bm = ptr_add(singletonrefs, header.singletonref_count * sizeof(vfoff)); - bm_end = ptr_add(table, header.table_size); + symrefs = TO_VOIDP(table); + rtdrefs = TO_VOIDP(ptr_add(TO_PTR(symrefs), header.symref_count * sizeof(vfoff))); + singletonrefs = TO_VOIDP(ptr_add(TO_PTR(rtdrefs), header.rtdref_count * sizeof(vfoff))); + bm = TO_VOIDP(ptr_add(TO_PTR(singletonrefs), header.singletonref_count * sizeof(vfoff))); + bm_end = TO_VOIDP(ptr_add(TO_PTR(table), header.table_size)); #if 0 printf("\n" @@ -333,7 +333,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) next_offset2 = vspace_offsets[s2+1]; \ } \ } while (0) -#define SPACE_PTR(off) ptr_add(vspaces[s2], (off) - offset2) +#define SPACE_PTR(off) TO_VOIDP(ptr_add(vspaces[s2], (off) - offset2)) /* Fix up pointers. The initial content has all pointers relative to the start of the data. Since the spaces of referenced pointers @@ -418,7 +418,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) if (S_vfasl_boot_mode > 0) { IGEN gen = SegInfo(ptr_get_segment(isym))->generation; if (gen < static_generation) { - printf("WARNING: vfasl symbol already interned, but at generation %d: %p ", gen, isym); + printf("WARNING: vfasl symbol already interned, but at generation %d: %p ", gen, TO_VOIDP(isym)); S_prin1(isym); printf("\n"); } @@ -443,15 +443,15 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) vfoff i; for (i = 0; i < header.symref_count; i++) { uptr p2_off, sym_pos; - ptr p2, sym, val; + ptr *p2, sym, val; p2_off = symrefs[i]; INC_SPACE_OFFSET(p2_off); p2 = SPACE_PTR(p2_off); - sym_pos = UNFIX(*(ptr **)p2); + sym_pos = UNFIX(*p2); sym = TYPE(ptr_add(syms, symbol_pos_to_offset(sym_pos)), type_symbol); if ((val = SYMVAL(sym)) != sunbound) sym = val; - *(ptr **)p2 = sym; + *p2 = sym; } } @@ -564,7 +564,7 @@ ptr S_vfasl(ptr bv, void *stream, iptr offset, iptr input_len) ptr S_vfasl_to(ptr bv) { - return S_vfasl(bv, (ptr)0, 0, Sbytevector_length(bv)); + return S_vfasl(bv, NULL, 0, Sbytevector_length(bv)); } /************************************************************/ @@ -576,14 +576,14 @@ static void vfasl_init(vfasl_info *vfi) { vfi->base_addr = (ptr)0; vfi->sym_count = 0; vfi->symref_count = 0; - vfi->symrefs = (ptr)0; + vfi->symrefs = NULL; vfi->base_rtd = S_G.base_rtd; vfi->rtdref_count = 0; - vfi->rtdrefs = (ptr)0; + vfi->rtdrefs = NULL; vfi->singletonref_count = 0; - vfi->singletonrefs = (ptr)0; + vfi->singletonrefs = NULL; vfi->graph = make_vfasl_hash_table(0); - vfi->ptr_bitmap = (ptr)0; + vfi->ptr_bitmap = NULL; vfi->installs_library_entry = 0; for (s = 0; s < vspaces_count; s++) { @@ -594,8 +594,8 @@ static void vfasl_init(vfasl_info *vfi) { c->length = 0; c->used = 0; c->swept = 0; - c->next = (ptr)0; - c->prev = (ptr)0; + c->next = NULL; + c->prev = NULL; vfi->spaces[s].first = c; vfi->spaces[s].total_bytes = 0; @@ -663,7 +663,7 @@ ptr S_to_vfasl(ptr v) bv = S_bytevector(size); memset(&BVIT(bv, 0), 0, size); - p = &BVIT(bv, 0); + p = TO_PTR(&BVIT(bv, 0)); /* Skip header for now */ p = ptr_add(p, sizeof(vfasl_header)); @@ -679,22 +679,22 @@ ptr S_to_vfasl(ptr v) c->length = vfi->spaces[s].total_bytes; c->used = 0; c->swept = 0; - c->next = (ptr)0; - c->prev = (ptr)0; + c->next = NULL; + c->prev = NULL; vfi->spaces[s].first = c; p = ptr_add(p, vfi->spaces[s].total_bytes); vfi->spaces[s].total_bytes = 0; } - vfi->symrefs = p; + vfi->symrefs = TO_VOIDP(p); p = ptr_add(p, sizeof(vfoff) * vfi->symref_count); vfi->base_rtd = S_G.base_rtd; - vfi->rtdrefs = p; + vfi->rtdrefs = TO_VOIDP(p); p = ptr_add(p, sizeof(vfoff) * vfi->rtdref_count); - vfi->singletonrefs = p; + vfi->singletonrefs = TO_VOIDP(p); p = ptr_add(p, sizeof(vfoff) * vfi->singletonref_count); vfi->sym_count = 0; @@ -704,7 +704,7 @@ ptr S_to_vfasl(ptr v) vfi->graph = make_vfasl_hash_table(0); - vfi->ptr_bitmap = p; + vfi->ptr_bitmap = TO_VOIDP(p); /* Write data */ @@ -714,7 +714,7 @@ ptr S_to_vfasl(ptr v) /* Make all pointers relative to the start of the data area */ { - ptr *p2 = vfi->base_addr; + ptr *p2 = TO_VOIDP(vfi->base_addr); uptr base_addr = (uptr)vfi->base_addr; octet *bm = vfi->ptr_bitmap; octet *bm_end = bm + bitmap_size; @@ -833,7 +833,7 @@ static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { break; case vspace_impure: while (pp < pp_end) { - vfasl_relocate(vfi, pp); + vfasl_relocate(vfi, TO_VOIDP(pp)); pp = ptr_add(pp, sizeof(ptr)); } break; @@ -865,7 +865,7 @@ static ptr vfasl_copy_all(vfasl_info *vfi, ptr v) { static void vfasl_register_pointer(vfasl_info *vfi, ptr *pp) { if (vfi->ptr_bitmap) { - uptr delta = ptr_diff(pp, vfi->base_addr) >> log2_ptr_bytes; + uptr delta = ptr_diff(TO_PTR(pp), vfi->base_addr) >> log2_ptr_bytes; uptr i = delta >> log2_byte_bits; uptr bit = (((uptr)1) << (delta & (byte_bits - 1))); vfi->ptr_bitmap[i] |= bit; @@ -881,7 +881,7 @@ static uptr ptr_base_diff(vfasl_info *vfi, ptr p) { static void vfasl_register_symbol_reference(vfasl_info *vfi, ptr *pp, ptr p) { if (vfi->symrefs) - vfi->symrefs[vfi->symref_count] = ptr_base_diff(vfi, pp); + vfi->symrefs[vfi->symref_count] = ptr_base_diff(vfi, TO_PTR(pp)); vfi->symref_count++; *pp = SYMVAL(p); /* replace symbol reference with index of symbol */ } @@ -894,7 +894,7 @@ static void vfasl_register_rtd_reference(vfasl_info *vfi, ptr pp) { static void vfasl_register_singleton_reference(vfasl_info *vfi, ptr *pp, int which) { if (vfi->singletonrefs) - vfi->singletonrefs[vfi->singletonref_count] = ptr_base_diff(vfi, pp); + vfi->singletonrefs[vfi->singletonref_count] = ptr_base_diff(vfi, TO_PTR(pp)); vfi->singletonref_count++; *pp = FIX(which); } @@ -959,7 +959,7 @@ static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) { new_c->used = 0; new_c->swept = 0; - new_c->prev = (ptr)0; + new_c->prev = NULL; new_c->next = c; c->prev = new_c; @@ -978,7 +978,7 @@ static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) { iptr newlen = segment_align(n); c = vfasl_malloc(sizeof(vfasl_chunk)); - c->bytes = vfasl_malloc(newlen); + c->bytes = TO_PTR(vfasl_malloc(newlen)); c->length = newlen; c->used = 0; c->swept = 0; @@ -987,7 +987,7 @@ static ptr vfasl_find_room(vfasl_info *vfi, int s, ITYPE t, iptr n) { if (old_c->next && !old_c->length) old_c = old_c->next; /* drop useless chunk created above */ - c->prev = (ptr)0; + c->prev = NULL; c->next = old_c; old_c->prev = c; @@ -1036,7 +1036,7 @@ static void vfasl_relocate(vfasl_info *vfi, ptr *ppp) { if ((TYPEBITS(pp) == type_typed_object) && TYPEP((tf = TYPEFIELD(pp)), mask_record, type_record) && is_rtd(tf, vfi)) - vfasl_register_rtd_reference(vfi, ppp); + vfasl_register_rtd_reference(vfi, TO_PTR(ppp)); vfasl_register_pointer(vfi, ppp); } } @@ -1101,6 +1101,8 @@ static IFASLCODE abs_reloc_variant(IFASLCODE type) { return reloc_ppc32_abs; else return reloc_abs; +#elif defined(PORTABLE_BYTECODE) + return reloc_pb_abs; #else >> need to fill in for this platform << #endif @@ -1274,7 +1276,8 @@ static void fasl_init_entry_tables() ptr entry = Svector_ref(S_G.library_entry_vector, i); if (entry != Sfalse) { vfasl_hash_table_set(S_G.library_entries, entry, (ptr)(i+1)); - vfasl_hash_table_set(S_G.library_entry_codes, CLOSCODE(entry), (ptr)(i+1)); + if (Sprocedurep(entry)) + vfasl_hash_table_set(S_G.library_entry_codes, CLOSCODE(entry), (ptr)(i+1)); } } } @@ -1365,7 +1368,7 @@ static void vfasl_hash_table_set(vfasl_hash_table *ht, ptr key, ptr value) { uptr hc = HASH_CODE(key); uptr hc2 = HASH_CODE2(key); uptr size = ht->size; - + if (ht->count > ht->size >> 1) { /* rehash */ uptr i; @@ -1404,7 +1407,7 @@ static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key) { uptr hc2 = HASH_CODE2(key); uptr size = ht->size; ptr old_key; - + hc = hc & (size - 1); while ((old_key = ht->entries[hc].key) != key) { if (!old_key) @@ -1417,15 +1420,15 @@ static ptr vfasl_hash_table_ref(vfasl_hash_table *ht, ptr key) { /*************************************************************/ -static ptr vfasl_malloc(uptr sz) { +static void *vfasl_malloc(uptr sz) { ptr tc = get_thread_context(); - ptr p; - thread_find_room(tc, typemod, ptr_align(sz), p) + void *p; + thread_find_room_voidp(tc, ptr_align(sz), p) return p; } -static ptr vfasl_calloc(uptr sz, uptr n) { - ptr p; +static void *vfasl_calloc(uptr sz, uptr n) { + void *p; sz *= n; p = vfasl_malloc(sz); memset(p, 0, sz); diff --git a/configure b/configure index 08cd3e473e..793064d9f0 100755 --- a/configure +++ b/configure @@ -25,6 +25,7 @@ machs=$machs$sep2$last m="" w="" +pb=no threads=yes nothreads=no temproot="" @@ -186,6 +187,9 @@ while [ $# != 0 ] ; do --32) bits=32 ;; + --pb) + pb=yes + ;; --installprefix=*) installprefix=`echo $1 | sed -e 's/^--installprefix=//'` ;; @@ -307,6 +311,13 @@ while [ $# != 0 ] ; do shift done +if [ "$m" = "pb" ] ; then + echo "Don't select pb using -m or --machine, because pb needs the" + echo " machine as the kernel host machine. Instead, use --pb to select" + echo " a pb (portable bytecode) build." + exit 1 +fi + if [ "$bits" = "" ] ; then if uname -a | egrep 'amd64|x86_64|aarch64' > /dev/null 2>&1 ; then bits=64 @@ -320,10 +331,16 @@ if [ "$threads" = "" ] ; then fi if [ "$m" = "" ] ; then - if [ $bits = 64 ] ; then - if [ $threads = yes ] ; then m=$tm64 ; else m=$m64 ; fi - else - if [ $threads = yes ] ; then m=$tm32 ; else m=$m32 ; fi + machine_supplied=no + if [ $pb = yes ] ; then + m=pb + if [ $bits = 64 ] ; then mpbhost=$m64 ; else mpbhost=$m32 ; fi + else + if [ $bits = 64 ] ; then + if [ $threads = yes ] ; then m=$tm64 ; else m=$m64 ; fi + else + if [ $threads = yes ] ; then m=$tm32 ; else m=$m32 ; fi + fi fi fi @@ -413,9 +430,17 @@ if [ "$help" = "yes" ]; then fi if [ "$m" = "" -o ! -f boot/$m/scheme.boot ] ; then - echo "no suitable machine type found" - echo "try rerunning as $0 -m=" - echo "available machine types: $machs" + echo "No suitable machine type found." + if [ "$machine_supplied" = "no" ] ; then + echo "Try rerunning as $0 -m=" + fi + echo "Available machine types: $machs" + if [ -f boot/pb/scheme.boot ] ; then + echo "A pb machine type is available, so you might also try" + echo " $0 --pb" + echo " make .bootquick" + echo "and then try $0 again." + fi exit 1 fi @@ -447,7 +472,7 @@ else fi fi -./workarea $m $w +./workarea $m $w $mpbhost sed -e 's/$(m)/'$m'/g'\ -e 's/$(workarea)/'$w'/g'\ @@ -501,6 +526,9 @@ if [ "$disablecurses" = "yes" ]; then ncursesLib= fi +warningFlags="-Wpointer-arith -Wall -Wextra -Werror -Wno-implicit-fallthrough" +optFlags=-O2 + cat > $w/c/Mf-config << END CC=$CC CPPFLAGS=$CPPFLAGS @@ -521,6 +549,9 @@ zlibLib=$zlibLib LZ4Lib=$LZ4Lib zlibHeaderDep=$zlibHeaderDep LZ4HeaderDep=$LZ4HeaderDep +warningFlags=$warningFlags +optFlags=$optFlags +KernelCFlags=$KernelCFlags Kernel=\${${Kernel}} KernelLinkDeps=\${${Kernel}LinkDeps} KernelLinkLibs=\${${Kernel}LinkLibs} diff --git a/csug/foreign.stex b/csug/foreign.stex index 606554ea99..f498b39799 100644 --- a/csug/foreign.stex +++ b/csug/foreign.stex @@ -1512,7 +1512,7 @@ where \var{length} is an exact nonnegative integer, \var{conv} is \scheme{#f} or a string naming a valid convention as described on page~\ref{page:conv-description}, signedness is either \scheme{signed} or \scheme{unsigned}, and -endianness is one of \scheme{native}, \scheme{big}, or \scheme{little}. +endianness is one of \scheme{native}, \scheme{swapped}, \scheme{big}, or \scheme{little}. A restriction not reflected above is that \scheme{function} ftypes cannot be used as the types of @@ -1695,17 +1695,23 @@ the \scheme{endian} ftype with a \scheme{big} or \scheme{little} \var{endianness} specifier. The \scheme{native} specifier can be used to force a return back to \scheme{native} representation. +The \scheme{swapped} specifier can be used to swap the +representation relative to the default or enclosing representation. Each \scheme{endian} form affects only ftypes nested syntactically within it and not nested within a closer \scheme{endian} form. The total size $n$ of the fields within an ftype bits form must -be 8, 16, 24, 32, 40, 48, 56, or 64. padding must be added manually if needed. +be 8, 16, 24, 32, 40, 48, 56, or 64. Padding must be added manually, if needed. In little-endian representation, the first field occupies the low-order bits of the containing 8, 16, 24, 32, 40, 48, 56, or 64-bit word, with each subsequent field just above the preceding field. In big-endian representation, the first field occupies the high-order bits, with each subsequent field just below the -preceding field. +preceding field. For a machine type where endianness is not +known at compile time (such as the porrtable bytecode +virtual machine), a bit field must be specified explicitly +as \scheme{big} or \scheme{little} endian by an enclosing +declaration. Two ftypes are considered equivalent only if defined by the same \scheme{ftype} binding. diff --git a/makefiles/Makefile-workarea.in b/makefiles/Makefile-workarea.in index e330fd7d08..48a1f8cda6 100644 --- a/makefiles/Makefile-workarea.in +++ b/makefiles/Makefile-workarea.in @@ -45,6 +45,19 @@ coverage: bootfiles: build $(MAKE) -f Mf-boot +.PHONY: reset +reset: + (cd s && $(MAKE) reset) + +%.boot: + mkdir -p ../boot/$* + $(MAKE) -f Mf-boot $*.boot + +%.bootquick: + (cd c && $(MAKE)) + mkdir -p boot/$* + $(MAKE) -f Mf-boot $*.boot o=3 d=0 what=all + .PHONY: bintar bintar: build (cd bintar && $(MAKE)) diff --git a/makefiles/Makefile.in b/makefiles/Makefile.in index 3c4ce64a2f..1dab66c8ad 100644 --- a/makefiles/Makefile.in +++ b/makefiles/Makefile.in @@ -43,11 +43,19 @@ coverage: bootfiles: (cd $(workarea) && $(MAKE) bootfiles) -# Supply XM= to build boot files for -.PHONY: boot -boot: build - mkdir -p boot/$(XM) - (cd $(workarea) && $(MAKE) -f Mf-boot $(XM).boot) +.PHONY: reset +reset: + (cd $(workarea) && $(MAKE) reset) + +# .boot to build boot files for +%.boot: + (cd $(workarea) && $(MAKE) $*.boot) + +# .bootquick to build boot files for +# with o=3 d=0 for the cross compiler, and only after +# building the kernel for the configured machine +%.bootquick: + (cd $(workarea) && $(MAKE) $*.bootquick) # Supply ORIG= to build using existing at .PHONY: from-orig diff --git a/makefiles/Mf-boot.in b/makefiles/Mf-boot.in index 6744c7407a..6dba150a84 100644 --- a/makefiles/Mf-boot.in +++ b/makefiles/Mf-boot.in @@ -19,7 +19,8 @@ doit: $(bootfiles) %.boot: ( cd .. ; ./workarea $* xc-$* ) - ( cd ../xc-$*/s ; make -f Mf-cross base=../../$(workarea) --jobs=2 m=$(m) xm=$* ) + ( cd ../xc-$*/s ; make -f Mf-cross base=../../$(workarea) m=$(m) xm=$* ) + mkdir -p ../boot/$* for x in `echo scheme.boot petite.boot scheme.h equates.h gc-oce.inc gc-ocd.inc vfasl.inc` ; do\ if [ ! -h ../xc-$*/boot/$*/$$x ] ; then \ mv -f ../xc-$*/boot/$*/$$x ../boot/$*/$$x ;\ diff --git a/makefiles/Mf-install.in b/makefiles/Mf-install.in index c588187ad5..3043e5d324 100644 --- a/makefiles/Mf-install.in +++ b/makefiles/Mf-install.in @@ -62,7 +62,7 @@ InstallLZ4Target= # no changes should be needed below this point # ############################################################################### -Version=csv9.5.3.34 +Version=csv9.5.3.35 Include=boot/$m PetiteBoot=boot/$m/petite.boot SchemeBoot=boot/$m/scheme.boot diff --git a/mats/7.ms b/mats/7.ms index 01667fdefa..4ff376769e 100644 --- a/mats/7.ms +++ b/mats/7.ms @@ -1149,7 +1149,9 @@ ; regression test to verify that we can evaluate a foreign-callable form inside the procedure to ; which scheme-start is set, which was failing because its relocation information was discarded ; by the static-generation collection. - (equal? + (or + (case (machine-type) [(pb) #t] [else #f]) ; no callables in pb + (equal? (begin (unless (or (embedded?) (equal? *scheme* (format "../bin/~a/scheme~a" (machine-type) (if (windows?) ".exe" "")))) (errorf #f "not testing boot file based on ../boot/~a/petite.boot, since *scheme* isn't ../bin/~a/scheme~a" @@ -1172,7 +1174,7 @@ (close-input-port from-stderr) (unless (eof-object? err) (error 'bootfile-test2 err)) out))) - "#\n") + "#\n")) ) (mat hostop diff --git a/mats/Mf-a6fb b/mats/Mf-a6fb index b16d1b60da..8876bcf9c5 100644 --- a/mats/Mf-a6fb +++ b/mats/Mf-a6fb @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6fb +m ?= a6fb fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6le b/mats/Mf-a6le index d6fee09cd6..77515234fe 100644 --- a/mats/Mf-a6le +++ b/mats/Mf-a6le @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6le +m ?= a6le fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -m64 -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6nb b/mats/Mf-a6nb index 48187ef9b2..4f15762dff 100644 --- a/mats/Mf-a6nb +++ b/mats/Mf-a6nb @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6nb +m ?= a6nb fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6nt b/mats/Mf-a6nt index 7e532a76e9..9c6e07c75e 100644 --- a/mats/Mf-a6nt +++ b/mats/Mf-a6nt @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6nt +m ?= a6nt fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so diff --git a/mats/Mf-a6ob b/mats/Mf-a6ob index 12758f303d..01c2b5b27c 100644 --- a/mats/Mf-a6ob +++ b/mats/Mf-a6ob @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6ob +m ?= a6ob fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-a6osx b/mats/Mf-a6osx index f1dbf85dc4..bdbe8e6d5c 100644 --- a/mats/Mf-a6osx +++ b/mats/Mf-a6osx @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6osx +m ?= a6osx fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so diff --git a/mats/Mf-a6s2 b/mats/Mf-a6s2 index eccb7d86f0..5e26b0bcc4 100644 --- a/mats/Mf-a6s2 +++ b/mats/Mf-a6s2 @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = a6s2 +m ?= a6s2 fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m64 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + gcc -m64 ${threadFlags} -fPIC -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c gcc -o cat_flush cat_flush.c diff --git a/mats/Mf-arm32le b/mats/Mf-arm32le index ce547827ee..da910c7e40 100644 --- a/mats/Mf-arm32le +++ b/mats/Mf-arm32le @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = arm32le +m ?= arm32le fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so diff --git a/mats/Mf-arm64le b/mats/Mf-arm64le new file mode 100644 index 0000000000..d2771a467d --- /dev/null +++ b/mats/Mf-arm64le @@ -0,0 +1,27 @@ +# Mf-arm64le +# Copyright 1984-2017 Cisco Systems, Inc. +# +# Licensed under the Apache License, Version 2.0 (the "License"); +# you may not use this file except in compliance with the License. +# You may obtain a copy of the License at +# +# http://www.apache.org/licenses/LICENSE-2.0 +# +# Unless required by applicable law or agreed to in writing, software +# distributed under the License is distributed on an "AS IS" BASIS, +# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +# See the License for the specific language governing permissions and +# limitations under the License. + +m ?= arm64le + +fsrc = foreign1.c foreign2.c foreign3.c foreign4.c +fobj = foreign1.so + +include Mf-base + +foreign1.so: ${fsrc} ../boot/$m/scheme.h + cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + +cat_flush: cat_flush.c + cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3fb b/mats/Mf-i3fb index 150cedbf44..2a29b2a9a6 100644 --- a/mats/Mf-i3fb +++ b/mats/Mf-i3fb @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3fb +m ?= i3fb fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3le b/mats/Mf-i3le index 8f521c8fd9..8bee4684fb 100644 --- a/mats/Mf-i3le +++ b/mats/Mf-i3le @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3le +m ?= i3le fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -m32 -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3nb b/mats/Mf-i3nb index e81f6ff862..dcd50948ee 100644 --- a/mats/Mf-i3nb +++ b/mats/Mf-i3nb @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3nb +m ?= i3nb fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3nt b/mats/Mf-i3nt index c65675f948..4dfc3238b1 100644 --- a/mats/Mf-i3nt +++ b/mats/Mf-i3nt @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3nt +m ?= i3nt fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so diff --git a/mats/Mf-i3ob b/mats/Mf-i3ob index 4e3ee1b32d..cbabe3fe16 100644 --- a/mats/Mf-i3ob +++ b/mats/Mf-i3ob @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3ob +m ?= i3ob fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-i3osx b/mats/Mf-i3osx index 53c7d4ab31..a2c67a2b04 100644 --- a/mats/Mf-i3osx +++ b/mats/Mf-i3osx @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3osx +m ?= i3osx fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so diff --git a/mats/Mf-i3s2 b/mats/Mf-i3s2 index c39fffec98..55f1cb4de1 100644 --- a/mats/Mf-i3s2 +++ b/mats/Mf-i3s2 @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = i3s2 +m ?= i3s2 fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + gcc -m32 -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c gcc -o cat_flush cat_flush.c diff --git a/mats/Mf-pb b/mats/Mf-pb new file mode 100644 index 0000000000..69b359460c --- /dev/null +++ b/mats/Mf-pb @@ -0,0 +1,5 @@ +# Mf-pb + +m = pb + +include Mf-pbhost diff --git a/mats/Mf-ppc32le b/mats/Mf-ppc32le index 28151a8376..1e8703a751 100644 --- a/mats/Mf-ppc32le +++ b/mats/Mf-ppc32le @@ -13,7 +13,7 @@ # See the License for the specific language governing permissions and # limitations under the License. -m = ppc32le +m ?= ppc32le fsrc = foreign1.c foreign2.c foreign3.c foreign4.c fobj = foreign1.so @@ -21,7 +21,7 @@ fobj = foreign1.so include Mf-base foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -fPIC -shared -I${Include} -o foreign1.so ${fsrc} + cc -m32 -fPIC ${threadFlags} -shared -I${Include} -o foreign1.so ${fsrc} cat_flush: cat_flush.c cc -o cat_flush cat_flush.c diff --git a/mats/Mf-ta6fb b/mats/Mf-ta6fb index 921d6098b4..6895aff210 100644 --- a/mats/Mf-ta6fb +++ b/mats/Mf-ta6fb @@ -1,27 +1,7 @@ # Mf-ta6fb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6fb -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -pthread -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-a6fb diff --git a/mats/Mf-ta6le b/mats/Mf-ta6le index cd014ec658..29ba25c3d1 100644 --- a/mats/Mf-ta6le +++ b/mats/Mf-ta6le @@ -1,27 +1,7 @@ # Mf-ta6le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6le -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -pthread -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m64 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-a6le diff --git a/mats/Mf-ta6nb b/mats/Mf-ta6nb index 6b1929d81c..0ed99a5b22 100644 --- a/mats/Mf-ta6nb +++ b/mats/Mf-ta6nb @@ -1,27 +1,7 @@ # Mf-ta6nb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6nb -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -pthread -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-a6nb diff --git a/mats/Mf-ta6nt b/mats/Mf-ta6nt index f8b3e8197b..9e1fb593ab 100644 --- a/mats/Mf-ta6nt +++ b/mats/Mf-ta6nt @@ -1,30 +1,5 @@ # Mf-ta6nt -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6nt -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so -mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj - -include Mf-base - -export MSYS_NO_PATHCONV=1 - -foreign1.so: $(fsrc) - cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)" - -cat_flush: cat_flush.c - cmd.exe /c "vs.bat amd64 && cl /DWIN32 /DX86_64 /MD /nologo $<" +include Mf-a6nt diff --git a/mats/Mf-ta6ob b/mats/Mf-ta6ob index a7aee9122f..e1b8f096e9 100644 --- a/mats/Mf-ta6ob +++ b/mats/Mf-ta6ob @@ -1,27 +1,7 @@ # Mf-ta6ob -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6ob -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -pthread -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-a6ob diff --git a/mats/Mf-ta6osx b/mats/Mf-ta6osx index 42da5d7c5d..2696b70f1e 100644 --- a/mats/Mf-ta6osx +++ b/mats/Mf-ta6osx @@ -1,27 +1,5 @@ # Mf-ta6osx -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6osx -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m64 -pthread -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-a6osx diff --git a/mats/Mf-ta6s2 b/mats/Mf-ta6s2 index c5f0b0e145..f8a11d60c0 100644 --- a/mats/Mf-ta6s2 +++ b/mats/Mf-ta6s2 @@ -1,27 +1,7 @@ # Mf-ta6s2 -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ta6s2 -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -D_REENTRANT -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m64 -D_REENTRANT -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - gcc -o cat_flush cat_flush.c +include Mf-a6s2 diff --git a/mats/Mf-tarm32le b/mats/Mf-tarm32le index c045adc159..6d67e1fd9b 100644 --- a/mats/Mf-tarm32le +++ b/mats/Mf-tarm32le @@ -1,27 +1,5 @@ # Mf-tarm32le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = tarm32le -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-arm32le diff --git a/mats/Mf-tarm64le b/mats/Mf-tarm64le index b93dcd7296..903f81643c 100644 --- a/mats/Mf-tarm64le +++ b/mats/Mf-tarm64le @@ -1,27 +1,5 @@ # Mf-tarm64le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = tarm64le -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-arm64le diff --git a/mats/Mf-ti3fb b/mats/Mf-ti3fb index c8911455ec..c83a9fa332 100644 --- a/mats/Mf-ti3fb +++ b/mats/Mf-ti3fb @@ -1,27 +1,7 @@ # Mf-ti3fb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3fb -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +threadFlags = -pthread + +include Mf-i3fb diff --git a/mats/Mf-ti3le b/mats/Mf-ti3le index 12e77b8358..70f3832bfb 100644 --- a/mats/Mf-ti3le +++ b/mats/Mf-ti3le @@ -1,27 +1,7 @@ # Mf-ti3le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3le -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -pthread -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-i3le diff --git a/mats/Mf-ti3nb b/mats/Mf-ti3nb index 028c652722..eb6f21bd41 100644 --- a/mats/Mf-ti3nb +++ b/mats/Mf-ti3nb @@ -1,27 +1,7 @@ # Mf-ti3nb -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3nb -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -pthread -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-i3nb diff --git a/mats/Mf-ti3nt b/mats/Mf-ti3nt index 31d6a672de..4a04350802 100644 --- a/mats/Mf-ti3nt +++ b/mats/Mf-ti3nt @@ -1,30 +1,5 @@ # Mf-ti3nt -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3nt -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so -mdclean = cat_flush.exe cat_flush.obj foreign1.exp foreign1.lib foreign1.obj foreign2.obj foreign3.obj - -include Mf-base - -export MSYS_NO_PATHCONV=1 - -foreign1.so: $(fsrc) - cmd.exe /c "vs.bat x86 && cl /DWIN32 /Fe$@ /I${Include} /LD /MD /nologo ../bin/$m/csv953.lib $(fsrc)" - -cat_flush: cat_flush.c - cmd.exe /c "vs.bat x86 && cl /DWIN32 /MD /nologo $<" +include Mf-i3nt diff --git a/mats/Mf-ti3ob b/mats/Mf-ti3ob index 8a4741c022..7c63270d5d 100644 --- a/mats/Mf-ti3ob +++ b/mats/Mf-ti3ob @@ -1,27 +1,7 @@ # Mf-ti3ob -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3ob -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -pthread -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-i3ob diff --git a/mats/Mf-ti3osx b/mats/Mf-ti3osx index 6913c3423d..2f0c8d7c11 100644 --- a/mats/Mf-ti3osx +++ b/mats/Mf-ti3osx @@ -1,27 +1,5 @@ # Mf-ti3osx -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3osx -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -pthread -dynamiclib -undefined dynamic_lookup -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +include Mf-i3osx diff --git a/mats/Mf-ti3s2 b/mats/Mf-ti3s2 index bb3b3605ec..7d7bcd125e 100644 --- a/mats/Mf-ti3s2 +++ b/mats/Mf-ti3s2 @@ -1,27 +1,7 @@ # Mf-ti3s2 -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = ti3s2 -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so +threadFlags = -D_REENTRANT -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - gcc -m32 -D_REENTRANT -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - gcc -o cat_flush cat_flush.c +include Mf-i3s2 diff --git a/mats/Mf-tppc32le b/mats/Mf-tppc32le index a12b515dee..34f4571a6e 100644 --- a/mats/Mf-tppc32le +++ b/mats/Mf-tppc32le @@ -1,27 +1,7 @@ # Mf-tppc32le -# Copyright 1984-2017 Cisco Systems, Inc. -# -# Licensed under the Apache License, Version 2.0 (the "License"); -# you may not use this file except in compliance with the License. -# You may obtain a copy of the License at -# -# http://www.apache.org/licenses/LICENSE-2.0 -# -# Unless required by applicable law or agreed to in writing, software -# distributed under the License is distributed on an "AS IS" BASIS, -# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -# See the License for the specific language governing permissions and -# limitations under the License. m = tppc32le -fsrc = foreign1.c foreign2.c foreign3.c foreign4.c -fobj = foreign1.so - -include Mf-base - -foreign1.so: ${fsrc} ../boot/$m/scheme.h - cc -m32 -pthread -fPIC -shared -I${Include} -o foreign1.so ${fsrc} - -cat_flush: cat_flush.c - cc -o cat_flush cat_flush.c +threadFlags = -pthread + +include Mf-ppc32le diff --git a/mats/bytevector.ms b/mats/bytevector.ms index 00f100ab31..e126dfc722 100644 --- a/mats/bytevector.ms +++ b/mats/bytevector.ms @@ -13,6 +13,18 @@ ;;; See the License for the specific language governing permissions and ;;; limitations under the License. +(define dynamic-native-endianness? + (case (machine-type) + [(pb) #t] + [else #f])) + +(define test-endian-sensitive-cp0-expansion + (if dynamic-native-endianness? + (case-lambda + [(expr expected) #t] + [(equiv? expr expected) #t]) + test-cp0-expansion)) + (mat native-endianness ; wrong argument count (error? (native-endianness 'big)) @@ -25,6 +37,7 @@ arm32le tarm32le arm64le tarm64le) 'little] [(ppc32le tppc32le) 'big] + [(pb) (native-endianness)] [else (errorf #f "unrecognized machine type")])) ) @@ -743,10 +756,12 @@ (native->signed 250 89) (native->signed 200 201))) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? '(bytevector-s16-native-ref #vu8(3 252 5) 0) (native->signed 3 252)) - (equal? + (or + dynamic-native-endianness? + (equal? ;; list doesn't get inlined, so take if off the front of the list (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize '(let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4]) @@ -763,7 +778,7 @@ (native->signed 23 55) (native->signed 23 55) (native->signed 250 89) - (native->signed 200 201))) + (native->signed 200 201)))) (do ([i 0 (fx+ i 1)]) ((fx= i (expt 2 8)) #t) @@ -811,10 +826,12 @@ (native->unsigned 250 89) (native->unsigned 200 201))) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? '(bytevector-u16-native-ref #vu8(3 252 5) 0) (native->unsigned 3 252)) - (equal? + (or + dynamic-native-endianness? + (equal? ;; list doesn't get inlined, so take if off the front of the list (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize '(let ([v #vu8(3 252 5 17 23 55 250 89 200 201 128)] [i 4]) @@ -831,7 +848,7 @@ (native->unsigned 23 55) (native->unsigned 23 55) (native->unsigned 250 89) - (native->unsigned 200 201))) + (native->unsigned 200 201)))) (do ([i 0 (fx+ i 1)]) ((fx= i (expt 2 8)) #t) @@ -3227,10 +3244,12 @@ (native->signed 248 189 190 207) (native->signed 24 25 26 27))) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? '(bytevector-s32-native-ref #vu8(3 252 5 32 65 87 20) 0) (native->signed 3 252 5 32)) - (equal? + (or + dynamic-native-endianness? + (equal? (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize '(let ([v '#vu8(30 100 200 250 249 199 99 29 @@ -3246,7 +3265,7 @@ (native->signed 30 100 200 250) (native->signed 249 199 99 29) (native->signed 248 189 190 207) - (native->signed 24 25 26 27))) + (native->signed 24 25 26 27)))) (do ([i 10000 (fx- i 1)]) ((fx= i 0) #t) @@ -3297,10 +3316,12 @@ (native->unsigned 248 189 190 207) (native->unsigned 24 25 26 27))) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? '(bytevector-u32-native-ref #vu8(3 252 5 32 65 87 20) 0) (native->unsigned 3 252 5 32)) - (equal? + (or + dynamic-native-endianness? + (equal? (cdr (parameterize ([optimize-level 2] [enable-cp0 #t] [#%$suppress-primitive-inlining #f]) (expand/optimize '(let ([v '#vu8(30 100 200 250 249 199 99 29 @@ -3316,7 +3337,7 @@ (native->unsigned 30 100 200 250) (native->unsigned 249 199 99 29) (native->unsigned 248 189 190 207) - (native->unsigned 24 25 26 27))) + (native->unsigned 24 25 26 27)))) (do ([i 10000 (fx- i 1)]) ((fx= i 0) #t) @@ -5549,36 +5570,36 @@ (eqv? (bytevector-s64-native-ref $v1 88) (native->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78)) - (test-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 0) 0) - (test-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 8) -1) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 0) 0) + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 8) -1) + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 16) (native->signed #x7f #xff #xff #xff #xff #xff #xff #xff)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 24) (native->signed #xff #xff #xff #xff #xff #xff #xff #x7f)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 32) (native->signed #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 40) (native->signed #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 48) (native->signed #x80 #x00 #x00 #x00 #xff #xff #xff #xff)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 56) (native->signed #xff #xff #xff #xff #x00 #x00 #x00 #x80)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 64) (native->signed #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 72) (native->signed #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 80) (native->signed #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-s64-native-ref ,$v1 88) (native->signed #xef #xde #xcd #xbc #xab #x9a #x89 #x78)) @@ -5669,38 +5690,38 @@ (eqv? (bytevector-u64-native-ref $v1 88) (native->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78)) - (test-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 0) 0) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 0) 0) + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 8) (- (expt 2 64) 1)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 16) (native->unsigned #x7f #xff #xff #xff #xff #xff #xff #xff)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 24) (native->unsigned #xff #xff #xff #xff #xff #xff #xff #x7f)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 32) (native->unsigned #x80 #x00 #x00 #x00 #x00 #x00 #x00 #x00)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 40) (native->unsigned #x00 #x00 #x00 #x00 #x00 #x00 #x00 #x80)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 48) (native->unsigned #x80 #x00 #x00 #x00 #xff #xff #xff #xff)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 56) (native->unsigned #xff #xff #xff #xff #x00 #x00 #x00 #x80)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 64) (native->unsigned #x12 #x23 #x34 #x45 #x56 #x67 #x78 #x89)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 72) (native->unsigned #x89 #x78 #x67 #x56 #x45 #x34 #x23 #x12)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 80) (native->unsigned #x78 #x89 #x9a #xab #xbc #xcd #xde #xef)) - (test-cp0-expansion eqv? + (test-endian-sensitive-cp0-expansion eqv? `(bytevector-u64-native-ref ,$v1 88) (native->unsigned #xef #xde #xcd #xbc #xab #x9a #x89 #x78)) diff --git a/mats/foreign.ms b/mats/foreign.ms index 9254c74b56..de2c6d86bf 100644 --- a/mats/foreign.ms +++ b/mats/foreign.ms @@ -23,6 +23,10 @@ [(_ [else e ...]) #'(begin (void) e ...)] [(_) #'(void)]))) +(machine-case + [(pb)] + [else + #;(define-syntax foreign-struct-mat (syntax-rules () [(_ name n) @@ -3238,3 +3242,5 @@ ((foreign-procedure __collect_safe __com 0 (iptr int) int) com-instance 3) ((foreign-procedure __collect_safe __com 4 (iptr int) int) com-instance 17)) 37))]) + +]) diff --git a/mats/ftype.ms b/mats/ftype.ms index 3cdffad19e..002b9d1d8e 100644 --- a/mats/ftype.ms +++ b/mats/ftype.ms @@ -1026,7 +1026,11 @@ ; ---------------- (begin - (define-ftype A (bits [x unsigned 3] [y unsigned 5])) + (meta-cond + [(eq? (machine-type) 'pb) + (define-ftype A (endian little (bits [x unsigned 3] [y unsigned 5])))] + [else + (define-ftype A (bits [x unsigned 3] [y unsigned 5]))]) (define-ftype B (* A)) (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A)))) (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B)))) @@ -1465,6 +1469,15 @@ (f (fx- n 1))))) (let ([s1 (statistics)]) (<= (- (sstats-bytes s1) (sstats-bytes s0)) 1000))))))) + (define-syntax pick-endianness-if-necessary + (lambda (stx) + (syntax-case stx () + [(_ (define-ftype id t)) + (cond + [(eq? (machine-type) 'pb) + #'(define-ftype id (endian little t))] + [else + #'(define-ftype id t)])]))) #t) ; might should also check ftype-&ref, ftype-locked-decr!, ftype-init-lock, @@ -1514,7 +1527,8 @@ ($not-much-alloc? #t (let () - (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])])) + (pick-endianness-if-necessary + (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))) (define-ftype B (* A)) (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A)))) (define b (make-ftype-pointer B (foreign-alloc (ftype-sizeof B)))) @@ -1540,7 +1554,8 @@ ($not-much-alloc? #t (let () - (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])])) + (pick-endianness-if-necessary + (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))) (define-ftype B (* A)) (define-ftype BB (struct [b1 char] [b2 B])) (define-ftype BBB (* BB)) @@ -1570,7 +1585,8 @@ ($not-much-alloc? #t (let () - (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])])) + (pick-endianness-if-necessary + (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))) (define-ftype C (struct [c1 int] [c2 A])) (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A)))) (define c (make-ftype-pointer C (foreign-alloc (ftype-sizeof C)))) @@ -1583,7 +1599,8 @@ ($not-much-alloc? #t (let () - (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])])) + (pick-endianness-if-necessary + (define-ftype A (struct [x (array 10 int)] [y (bits [y1 unsigned 3] [y2 unsigned 12] [y3 signed 17])]))) (define a (make-ftype-pointer A (foreign-alloc (ftype-sizeof A)))) (define a-addr (ftype-pointer-address a)) (lambda (n) @@ -2403,18 +2420,22 @@ (eqv? (ftype-ref Bl (a) bl) -3.14) (or (not (eq? (native-endianness) 'little)) + (eq? (machine-type) 'pb) (eqv? (ftype-ref D () bl) -3.14)) (eqv? (ftype-ref Dl () bl) -3.14) (or (not (eq? (native-endianness) 'little)) + (eq? (machine-type) 'pb) (eqv? (ftype-ref double () bl) -3.14)) (error? ; invalid syntax (ftype-ref (endian little double) () bl)) (eqv? (ftype-ref Bb (a) bb) -3.14) (or (not (eq? (native-endianness) 'big)) + (eq? (machine-type) 'pb) (eqv? (ftype-ref D () bb) -3.14)) (eqv? (ftype-ref Db () bb) -3.14) (or (not (eq? (native-endianness) 'big)) + (eq? (machine-type) 'pb) (eqv? (ftype-ref double () bb) -3.14)) (error? ; invalid syntax (ftype-ref (endian big double) () bb)) @@ -3125,7 +3146,8 @@ ; ---------------- (begin - (define-ftype Ebits (bits [x signed 32])) + (pick-endianness-if-necessary + (define-ftype Ebits (bits [x signed 32]))) (define ebits (make-ftype-pointer Ebits 0)) #t) @@ -5554,17 +5576,23 @@ (equal? (ftype-pointer-ftype (make-ftype-pointer A 0)) - (case (native-endianness) - [(big) '(endian little double)] - [(little) 'double] - [else (errorf #f "unexpected native endianness")])) + (cond + [(eq? (machine-type) 'pb) '(endian little double)] + [else + (case (native-endianness) + [(big) '(endian little double)] + [(little) 'double] + [else (errorf #f "unexpected native endianness")])])) (equal? (ftype-pointer-ftype (make-ftype-pointer B 0)) - (case (native-endianness) - [(big) 'double] - [(little) '(endian big double)] - [else (errorf #f "unexpected native endianness")])) + (cond + [(eq? (machine-type) 'pb) '(endian big double)] + [else + (case (native-endianness) + [(big) 'double] + [(little) '(endian swapped double)] + [else (errorf #f "unexpected native endianness")])])) (begin (define-ftype A (endian little char)) diff --git a/mats/io.ms b/mats/io.ms index 455636cdc7..f7fa30ad94 100644 --- a/mats/io.ms +++ b/mats/io.ms @@ -532,7 +532,9 @@ 1) ) -(if (embedded?) +(if (case (machine-type) + [(pb) #t] + [else (embedded?)]) (mat iconv-codec (error? (errorf 'iconv-codec "-73 is not a string")) (error? (errorf 'transcoded-port "unsupported encoding almost certainly bogus")) diff --git a/mats/misc.ms b/mats/misc.ms index 65671fdefb..708cdad297 100644 --- a/mats/misc.ms +++ b/mats/misc.ms @@ -4697,7 +4697,8 @@ (#2%display 1)))) ) -(unless (memq (machine-type) '(arm32le tarm32le arm64le tarm64le)) ; timestamp counter tends to be priviledged on Arm +(unless (memq (machine-type) '(arm32le tarm32le arm64le tarm64le ; timestamp counter tends to be priviledged on Arm + pb)) ; doesn't increment for pb (mat $read-time-stamp-counter (let ([t (#%$read-time-stamp-counter)]) diff --git a/mats/root-experr-compile-0-f-f-f b/mats/root-experr-compile-0-f-f-f index c57fdd61a8..0c375c99d1 100644 --- a/mats/root-experr-compile-0-f-f-f +++ b/mats/root-experr-compile-0-f-f-f @@ -10014,8 +10014,8 @@ foreign.mo:Expected error in mat foreign-ftype: "invalid foreign-procedure resul foreign.mo:Expected error in mat foreign-ftype: "invalid foreign-procedure result type specifier hag". foreign.mo:Expected error in mat foreign-ftype: "invalid (non-base) foreign-procedure argument ftype A". foreign.mo:Expected error in mat foreign-ftype: "invalid (non-base) foreign-procedure result ftype A". -foreign.mo:Expected error in mat foreign-ftype: "invalid (swapped) foreign-procedure argument ftype swap-fixnum". -foreign.mo:Expected error in mat foreign-ftype: "invalid (swapped) foreign-procedure result ftype swap-fixnum". +foreign.mo:Expected error in mat foreign-ftype: "invalid (not native) foreign-procedure argument ftype swap-fixnum". +foreign.mo:Expected error in mat foreign-ftype: "invalid (not native) foreign-procedure result ftype swap-fixnum". foreign.mo:Expected error in mat foreign-ftype: "invalid syntax (define-ftype foo (function "wtf" () void) +)". foreign.mo:Expected error in mat foreign-ftype: "invalid function-ftype convention "wtf"". foreign.mo:Expected error in mat foreign-ftype: "invalid function-ftype argument type specifier void". @@ -10268,7 +10268,7 @@ ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-b ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-locked-incr! A (f f2 0) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-integer or non-word-size field unsupported (ftype-locked-incr! A (f f2 0 f3a) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-locked-incr! A (g) x)". -ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on swapped field unsupported (ftype-locked-incr! A (h) x)". +ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-native field unsupported (ftype-locked-incr! A (h) x)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-locked-decr!)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-locked-decr! A)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-locked-decr! A x)". @@ -10284,7 +10284,7 @@ ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-b ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-locked-decr! A (f f2 0) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-integer or non-word-size field unsupported (ftype-locked-decr! A (f f2 0 f3a) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-locked-decr! A (g) x)". -ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on swapped field unsupported (ftype-locked-decr! A (h) x)". +ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-native field unsupported (ftype-locked-decr! A (h) x)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-init-lock!)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-init-lock! A)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-init-lock! A x)". @@ -10300,7 +10300,7 @@ ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-b ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-init-lock! A (f f2 0) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-integer or non-word-size field unsupported (ftype-init-lock! A (f f2 0 f3a) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-init-lock! A (g) x)". -ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on swapped field unsupported (ftype-init-lock! A (h) x)". +ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-native field unsupported (ftype-init-lock! A (h) x)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-lock!)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-lock! A)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-lock! A x)". @@ -10316,7 +10316,7 @@ ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-b ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-lock! A (f f2 0) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-integer or non-word-size field unsupported (ftype-lock! A (f f2 0 f3a) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-lock! A (g) x)". -ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on swapped field unsupported (ftype-lock! A (h) x)". +ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-native field unsupported (ftype-lock! A (h) x)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-spin-lock!)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-spin-lock! A)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-spin-lock! A x)". @@ -10332,7 +10332,7 @@ ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-b ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-spin-lock! A (f f2 0) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-integer or non-word-size field unsupported (ftype-spin-lock! A (f f2 0 f3a) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-spin-lock! A (g) x)". -ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on swapped field unsupported (ftype-spin-lock! A (h) x)". +ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-native field unsupported (ftype-spin-lock! A (h) x)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-unlock!)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-unlock! A)". ftype.mo:Expected error in mat ftype-lock-operations: "invalid syntax (ftype-unlock! A x)". @@ -10348,7 +10348,7 @@ ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-b ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-unlock! A (f f2 0) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-integer or non-word-size field unsupported (ftype-unlock! A (f f2 0 f3a) x)". ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-base-type field unsupported (ftype-unlock! A (g) x)". -ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on swapped field unsupported (ftype-unlock! A (h) x)". +ftype.mo:Expected error in mat ftype-lock-operations: "locked operation on non-native field unsupported (ftype-unlock! A (h) x)". ftype.mo:Expected error in mat ftype-bits: "ftype-set!: invalid value 113886 for bit field of size 1". ftype.mo:Expected error in mat ftype-bits: "ftype-set!: invalid value #\a for bit field of size 3". ftype.mo:Expected error in mat ftype-bits: "ftype-set!: invalid value oops for bit field of size 14". diff --git a/s/6.ss b/s/6.ss index 3edcffd81c..8ee9769387 100644 --- a/s/6.ss +++ b/s/6.ss @@ -71,7 +71,7 @@ (let () (define who 'mkdir) - (define fp (foreign-procedure "(cs)mkdir" (string uptr) ptr)) + (define fp (foreign-procedure "(cs)mkdir" (string int) ptr)) (define (do-mkdir path mode) (unless (string? path) ($oops who "~s is not a string" path)) @@ -94,7 +94,7 @@ [(path mode) (do-mkdir path mode)]))) (define-who chmod - (let ([fp (foreign-procedure "(cs)chmod" (string fixnum) ptr)]) + (let ([fp (foreign-procedure "(cs)chmod" (string int) ptr)]) (lambda (path mode) (unless (string? path) ($oops who "~s is not a string" path)) (unless (fixnum? mode) ($oops who "~s is not a fixnum" mode)) @@ -159,7 +159,7 @@ [(_ name path-name fd-name) (set-who! name (let ([path-fp (foreign-procedure path-name (string boolean) ptr)] - [fd-fp (foreign-procedure fd-name (fixnum) ptr)]) + [fd-fp (foreign-procedure fd-name (int) ptr)]) (case-lambda [(file) (file-x-time who path-fp fd-fp file #t)] [(file follow?) (file-x-time who path-fp fd-fp file follow?)])))])) diff --git a/s/7.ss b/s/7.ss index 447c1ad63d..cc9fdf4d3d 100644 --- a/s/7.ss +++ b/s/7.ss @@ -134,7 +134,7 @@ (set-who! fasl-read (let () - (define $fasl-read (foreign-procedure "(cs)fasl_read" (int fixnum ptr ptr) ptr)) + (define $fasl-read (foreign-procedure "(cs)fasl_read" (int int ptr ptr) ptr)) (define $bv-fasl-read (foreign-procedure "(cs)bv_fasl_read" (ptr int uptr uptr ptr ptr) ptr)) (define (get-uptr p) (let ([k (get-u8 p)]) diff --git a/s/Mf-base b/s/Mf-base index c8006135fb..ccd074da2e 100644 --- a/s/Mf-base +++ b/s/Mf-base @@ -579,6 +579,7 @@ setup.so: debug.ss ${patchobj}: ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss env.ss cpnanopass.$m cpnanopass.patch: nanopass.so np-languages.ss fxmap.ss ${archincludes} +cptypes.$m: fxmap.ss 5_4.$m: ../unicode/unicode-char-cases.ss ../unicode/unicode-charinfo.ss ${Cheader}: mkheader.so ${macroobj} nanopass.so base-lang.ss expand-lang.ss primref.ss types.ss io-types.ss fasl-helpers.ss hashtable-types.ss @@ -639,3 +640,18 @@ prettyclean: profileclean: prettyclean rm -f ${ProfileDumpSource} ${ProfileDumpBlock} + +.PHONY: reset +reset: + $(MAKE) reset-one FILE=petite.boot + $(MAKE) reset-one FILE=scheme.boot + $(MAKE) reset-one FILE=equates.h + $(MAKE) reset-one FILE=scheme.h + $(MAKE) reset-one FILE=gc-oce.inc + $(MAKE) reset-one FILE=gc-ocd.inc + $(MAKE) reset-one FILE=vfasl.inc + +.PHONY: reset-one +reset-one: + if [ -f ../boot/${m}/${FILE} ] ; then rm ../boot/${m}/${FILE} ; fi + if [ ! -h ../boot/${m}/${FILE} ] ; then ln -s ../../../boot/${m}/${FILE} ../boot/${m}/${FILE} ; fi diff --git a/s/Mf-pb b/s/Mf-pb new file mode 100644 index 0000000000..30286f9635 --- /dev/null +++ b/s/Mf-pb @@ -0,0 +1,6 @@ +# Mf-pb + +m = pb +archincludes = pb.ss + +include Mf-base diff --git a/s/back.ss b/s/back.ss index 5ceeb067a1..4a03d4ae5d 100644 --- a/s/back.ss +++ b/s/back.ss @@ -44,8 +44,8 @@ x))) (define-who collect-maximum-generation - (let ([$get-maximum-generation (foreign-procedure "(cs)maxgen" () fixnum)] - [$set-maximum-generation! (foreign-procedure "(cs)set_maxgen" (fixnum) void)]) + (let ([$get-maximum-generation (foreign-procedure "(cs)maxgen" () int)] + [$set-maximum-generation! (foreign-procedure "(cs)set_maxgen" (int) void)]) (case-lambda [() ($get-maximum-generation)] [(g) @@ -56,8 +56,8 @@ ($set-maximum-generation! g)]))) (define-who release-minimum-generation - (let ([$get-release-minimum-generation (foreign-procedure "(cs)minfreegen" () fixnum)] - [$set-release-minimum-generation! (foreign-procedure "(cs)set_minfreegen" (fixnum) void)]) + (let ([$get-release-minimum-generation (foreign-procedure "(cs)minfreegen" () int)] + [$set-release-minimum-generation! (foreign-procedure "(cs)set_minfreegen" (int) void)]) (case-lambda [() ($get-release-minimum-generation)] [(g) @@ -67,8 +67,8 @@ ($set-release-minimum-generation! g)]))) (define-who in-place-minimum-generation - (let ([$get-mark-minimum-generation (foreign-procedure "(cs)minmarkgen" () fixnum)] - [$set-mark-minimum-generation! (foreign-procedure "(cs)set_minmarkgen" (fixnum) void)]) + (let ([$get-mark-minimum-generation (foreign-procedure "(cs)minmarkgen" () int)] + [$set-mark-minimum-generation! (foreign-procedure "(cs)set_minmarkgen" (int) void)]) (case-lambda [() ($get-mark-minimum-generation)] [(g) diff --git a/s/bytevector.ss b/s/bytevector.ss index 026cbc386e..f9b8366933 100644 --- a/s/bytevector.ss +++ b/s/bytevector.ss @@ -296,8 +296,8 @@ [(kwd s/u bits) (with-syntax ([prim-name (construct-name #'kwd "bytevector-" #'s/u #'bits "-ref")] [native-name (construct-name #'kwd "bytevector-" #'s/u #'bits "-native-ref")] - [little-set! (construct-name #'kwd "little-ref-" #'s/u #'bits)] - [big-set! (construct-name #'kwd "big-ref-" #'s/u #'bits)]) + [little-ref (construct-name #'kwd "little-ref-" #'s/u #'bits)] + [big-ref (construct-name #'kwd "big-ref-" #'s/u #'bits)]) #`(lambda (v i eness who) (unless (bytevector? v) (not-a-bytevector who v)) (unaligned-ref-check who (fxquotient bits 8) v i) @@ -495,8 +495,16 @@ ) (set! native-endianness - (lambda () - (#2%native-endianness))) + (constant-case native-endianness + [(unknown) + (let ([endianness (if ((foreign-procedure "(cs)native_little_endian" () boolean)) + 'little + 'big)]) + (lambda () + endianness))] + [else + (lambda () + (#2%native-endianness))])) (set-who! make-bytevector (case-lambda @@ -954,14 +962,16 @@ (#3%bytevector-ieee-single-native-ref v i) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-ref v i) (unrecognized-endianness who eness))) (if (eq? eness (native-endianness)) (noswap-ref v i) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-ref v i) (unrecognized-endianness who eness)))))) @@ -998,14 +1008,16 @@ (#3%bytevector-ieee-double-native-ref v i) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-ref v i) (unrecognized-endianness who eness))) (if (eq? eness (native-endianness)) (noswap-ref v i) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-ref v i) (unrecognized-endianness who eness)))))) @@ -1033,14 +1045,16 @@ (#3%bytevector-ieee-single-native-set! v i x) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-set! v i x) (unrecognized-endianness who eness))) (if (eq? eness (native-endianness)) (noswap-set! v i x) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-set! v i x) (unrecognized-endianness who eness))))))) @@ -1076,14 +1090,16 @@ (#3%bytevector-ieee-double-native-set! v i x) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-set! v i x) (unrecognized-endianness who eness))) (if (eq? eness (native-endianness)) (noswap-set! v i x) (if (constant-case native-endianness [(little) (eq? eness 'big)] - [(big) (eq? eness 'little)]) + [(big) (eq? eness 'little)] + [(unknown) (or (eq? eness 'big) (eq? eness 'little))]) (swap-set! v i x) (unrecognized-endianness who eness))))))) @@ -1266,7 +1282,10 @@ [else (constant-case native-endianness [(little) (little->list v size)] - [(big) (big->list v size)])]) + [(big) (big->list v size)] + [(unknown) (if (eq? eness 'little) + (little->list v size) + (big->list v size))])]) (constant-case native-endianness [(little) (if (eq? eness 'big) @@ -1275,7 +1294,13 @@ [(big) (if (eq? eness 'little) (little->list v size) - (unrecognized-endianness who eness))])))) + (unrecognized-endianness who eness))] + [(unknown) + (if (eq? eness 'big) + (big->list v size) + (if (eq? eness 'little) + (little->list v size) + (unrecognized-endianness who eness)))])))) (set-who! bytevector->uint-list (lambda (v eness size) @@ -1308,7 +1333,10 @@ [else (constant-case native-endianness [(little) (little->list v size)] - [(big) (big->list v size)])]) + [(big) (big->list v size)] + [(unknown) (if (eq? eness 'little) + (little->list v size) + (big->list v size))])]) (constant-case native-endianness [(little) (if (eq? eness 'big) @@ -1317,7 +1345,13 @@ [(big) (if (eq? eness 'little) (little->list v size) - (unrecognized-endianness who eness))])))) + (unrecognized-endianness who eness))] + [(unknown) + (if (eq? eness 'big) + (big->list v size) + (if (eq? eness 'little) + (little->list v size) + (unrecognized-endianness who eness)))])))) ) (let () @@ -1397,7 +1431,10 @@ [else (constant-case native-endianness [(little) (list->little ls size)] - [(big) (list->big ls size)])]) + [(big) (list->big ls size)] + [(unknown) (if (eq? eness 'little) + (list->little ls size) + (list->big ls size))])]) (constant-case native-endianness [(little) (if (eq? eness 'big) @@ -1406,7 +1443,13 @@ [(big) (if (eq? eness 'little) (list->little ls size) - (unrecognized-endianness who eness))])))) + (unrecognized-endianness who eness))] + [(unknown) + (if (eq? eness 'big) + (list->big ls size) + (if (eq? eness 'little) + (list->little ls size) + (unrecognized-endianness who eness)))])))) (set-who! uint-list->bytevector (lambda (ls eness size) @@ -1445,7 +1488,10 @@ [else (constant-case native-endianness [(little) (list->little ls size)] - [(big) (list->big ls size)])]) + [(big) (list->big ls size)] + [(unknown) (if (eq? eness 'little) + (list->little ls size) + (list->big ls size))])]) (constant-case native-endianness [(little) (if (eq? eness 'big) @@ -1454,7 +1500,13 @@ [(big) (if (eq? eness 'little) (list->little ls size) - (unrecognized-endianness who eness))])))) + (unrecognized-endianness who eness))] + [(unknown) + (if (eq? eness 'big) + (list->big ls size) + (if (eq? eness 'little) + (list->little ls size) + (unrecognized-endianness who eness)))])))) ) (let () diff --git a/s/cmacros.ss b/s/cmacros.ss index 296e60f2be..12cf4b8c30 100644 --- a/s/cmacros.ss +++ b/s/cmacros.ss @@ -348,7 +348,7 @@ ;; --------------------------------------------------------------------- ;; Version and machine types: -(define-constant scheme-version #x09050322) +(define-constant scheme-version #x09050323) (define-syntax define-machine-types (lambda (x) @@ -384,12 +384,18 @@ arm32le tarm32le ppc32le tppc32le arm64le tarm64le + pb ) (include "machine.def") (define-constant machine-type-name (cdr (assv (constant machine-type) (constant machine-type-alist)))) +(define-constant fasl-endianness + (constant-case architecture + [(pb) 'little] + [else (constant native-endianness)])) + ;; --------------------------------------------------------------------- ;; Some object-layout constants: @@ -552,7 +558,8 @@ (x86_64 reloc-x86_64-call reloc-x86_64-jump reloc-x86_64-popcount) (arm32 reloc-arm32-abs reloc-arm32-call reloc-arm32-jump) (arm64 reloc-arm64-abs reloc-arm64-call reloc-arm64-jump) - (ppc32 reloc-ppc32-abs reloc-ppc32-call reloc-ppc32-jump)) + (ppc32 reloc-ppc32-abs reloc-ppc32-call reloc-ppc32-jump) + (pb reloc-pb-abs reloc-pb-proc)) (constant-case ptr-bits [(64) @@ -655,6 +662,14 @@ (define-constant ERROR_VALUES 7) (define-constant ERROR_MVLET 8) +(define-constant open-fd-no-create #b0000001) +(define-constant open-fd-no-fail #b0000010) +(define-constant open-fd-no-truncate #b0000100) +(define-constant open-fd-append #b0001000) +(define-constant open-fd-lock #b0010000) +(define-constant open-fd-replace #b0100000) +(define-constant open-fd-compressed #b1000000) + ;; --------------------------------------------------------------------- ;; GC constants @@ -1164,6 +1179,12 @@ ,(constant-case ptr-bits [(32) 'unsigned-32] [(64) 'unsigned-64])) + ;; `xptr` is the same representation as `ptr`, + ;; but does not refer to a Scheme object: + (xptr . + ,(constant-case ptr-bits + [(32) 'unsigned-32] + [(64) 'unsigned-64])) (void* . ,(constant-case ptr-bits [(32) 'unsigned-32] @@ -1466,28 +1487,28 @@ ;;; make sure gc sweeps all ptrs (define-primitive-structure-disps tc typemod - ([void* arg-regs (constant asm-arg-reg-max)] - [void* ac0] - [void* ac1] - [void* sfp] - [void* cp] - [void* esp] - [void* ap] - [void* eap] - [void* ret] - [void* trap] - [void* xp] - [void* yp] - [void* ts] - [void* td] - [void* real_eap] + ([xptr arg-regs (constant asm-arg-reg-max)] + [xptr ac0] + [xptr ac1] + [xptr sfp] + [xptr cp] + [xptr esp] + [xptr ap] + [xptr eap] + [xptr ret] + [xptr trap] + [xptr xp] + [xptr yp] + [xptr ts] + [xptr td] + [xptr real_eap] [ptr virtual-registers (constant virtual-register-count)] [ptr guardian-entries] [ptr cchain] [ptr code-ranges-to-flush] [U32 random-seed] [I32 active] - [void* scheme-stack] + [xptr scheme-stack] [ptr stack-cache] [ptr stack-link] [iptr scheme-stack-size] @@ -1531,7 +1552,7 @@ [ptr default-record-hash-procedure] [ptr compress-format] [ptr compress-level] - [void* lz4-out-buffer] + [xptr lz4-out-buffer] [U64 instr-counter] [U64 alloc-counter] [ptr parameters] @@ -2939,3 +2960,285 @@ flexpt flsqrt)) ) + + +;; --------------------------------------------------------------------- +;; Portable bytecode - see "pb.ss" + +(constant-case architecture + [(pb) + + ;; Enumerated constants can be multiplied by the width of another + ;; enumeration, which is handy for encoding instructions: + (define-syntax define-pb-enum + (let ([gen (lambda (id scale all-enums) + (let loop ([enums (cdr all-enums)] [i 0]) + (cond + [(null? enums) + #`(define-constant #,id '#,all-enums)] + [else + #`(begin + (define-constant #,(car enums) '#,i) + #,(loop (cdr enums) (fx+ i scale)))])))]) + (lambda (stx) + (syntax-case stx (<<) + [(_ id << scale-id + enum ...) + (gen #'id + (let loop ([scale-sym (datum scale-id)]) + (if scale-sym + (let ([desc (lookup-constant scale-sym)]) + (fx* (length (cdr desc)) + (loop (car desc)))) + 1)) + #'(scale-id enum ...))] + [(_ id enum ...) + (gen #'id + 1 + #'(#f enum ...))])))) + + ;; Each opcode has variants that are defined by enumerations, where + ;; each enumeration must be scaled by a specific other enumerations + ;; (and we check consistency in this macro): + (define-syntax define-pb-opcode + (lambda (stx) + (syntax-case stx () + [(_ clause ...) + (let c-loop ([clause* #'(clause ...)] [i 0]) + (cond + [(null? clause*) + (unless (fx< i 256) + (error 'define-pb-opcode "too many combinations: ~a" i)) + #'(begin)] + [else + (syntax-case (car clause*) () + [[id field-id ...] + (let ([defns + (let loop ([id #'id] [field-id* #'(field-id ...)] [i i]) + (cond + [(null? field-id*) + (list #`(define-constant #,id '#,i))] + [else + (let* ([parent+fields (lookup-constant (syntax->datum (car field-id*)))] + [parent (car parent+fields)]) + (unless (if parent + (and (pair? (cdr field-id*)) + (eq? parent (syntax->datum (cadr field-id*)))) + (null? (cdr field-id*))) + (syntax-error (car field-id*) "misuse use of field")) + (let f-loop ([fields (cdr parent+fields)] [i i]) + (cond + [(null? fields) + '()] + [else + (let ([defns (loop (datum->syntax id + (string->symbol (format "~a-~a" (syntax->datum id) (car fields)))) + (cdr field-id*) + i)]) + (append + defns + (f-loop (cdr fields) (fx+ i (length defns)))))])))]))]) + #`(begin + (define-constant id '#,i) + #,@defns + #,(c-loop (cdr clause*) (fx+ i (length defns)))))])]))]))) + + ;; Most instrictions have register- and immediate-argument variants: + (define-pb-enum pb-argument-types + pb-register + pb-immediate) + + ;; Some instructions have size variants, always combined + ;; with register- and immediate-argument possibilties + ;; -- although some combinations may be unimplemented + ;; or not make sense, such as immediate-arrgument operations + ;; on double-precision floating-point numbers + (define-pb-enum pb-sizes << pb-argument-types + pb-int8 + pb-uint8 + pb-int16 + pb-uint16 + pb-int32 + pb-uint32 + pb-int64 + pb-uint64 + pb-single + pb-double) + + (define-pb-enum pb-move-types + pb-i->i + pb-d->d + pb-i->d + pb-d->i + pb-s->d + pb-d->s + pb-i-bits->d-bits ; 64-bit only + pb-d-bits->i-bits ; 64-bit only + pb-i-i-bits->d-bits ; 32-bit only + pb-d-lo-bits->i-bits ; 32-bit only + pb-d-hi-bits->i-bits) ; 32-bit only + + (define-pb-enum pb-binaries << pb-argument-types + pb-add + pb-sub + pb-mul + pb-div + pb-subz + pb-and + pb-ior + pb-xor + pb-lsl + pb-lsr + pb-asr + pb-lslo) + + (define-pb-enum pb-signals << pb-binaries + pb-no-signal + pb-signal) + + (define-pb-enum pb-unaries << pb-argument-types + pb-not + pb-sqrt) + + (define-pb-enum pb-compares << pb-argument-types + pb-eq + pb-lt + pb-gt + pb-le + pb-ge + pb-ab + pb-bl + pb-cs + pb-cc) + + (define-pb-enum pb-branches << pb-argument-types + pb-fals + pb-true + pb-always) + + (define-pb-enum pb-shifts + pb-shift0 + pb-shift1 + pb-shift2 + pb-shift3) + + (define-pb-enum pk-keeps << pb-shifts + pb-zero-bits + pb-keep-bits) + + (define-pb-opcode + [pb-mov16 pk-keeps pb-shifts] + [pb-mov pb-move-types] + [pb-bin-op pb-signals pb-binaries pb-argument-types] + [pb-cmp-op pb-compares pb-argument-types] + [pb-fp-bin-op pb-binaries pb-argument-types] + [pb-un-op pb-unaries pb-argument-types] + [pb-fp-un-op pb-unaries pb-argument-types] + [pb-fp-cmp-op pb-compares pb-argument-types] + [pb-rev-op pb-sizes pb-argument-types] + [pb-ld-op pb-sizes pb-argument-types] + [pb-st-op pb-sizes pb-argument-types] + [pb-b-op pb-branches pb-argument-types] + [pb-b*-op pb-argument-types] + [pb-call] + [pb-return] + [pb-interp] + [pb-adr] + [pb-inc pb-argument-types] + [pb-lock] + [pb-cas]) + + ;; Only foreign procedures that match specific prototypes are + ;; supported, where each prototype must be handled in "pb.c" + + (define-syntax define-pb-prototypes + (lambda (stx) + (syntax-case stx () + [(moi proto ...) + (let loop ([proto* #'(proto ...)] [i 0] [table '()]) + (cond + [(null? proto*) + #`(define-constant pb-prototype-table '#,(datum->syntax #'moi table))] + [else + (let* ([proto (syntax->datum (car proto*))] + [name (datum->syntax + #'moi + (string->symbol + (apply string-append "pb-call" (map (lambda (t) + (string-append "-" (symbol->string t))) + proto))))]) + #`(begin + (define-constant #,name '#,i) + #,(loop (cdr proto*) (fx+ i 1) (cons (cons proto i) table))))]))]))) + + (define-pb-prototypes + [void] ; return void + [void uptr] ; return void, one `uptr` argument + [void int32] ; etc. + [void uint32] + [void void*] + [void uptr uint32] + [void int32 uptr] + [void int32 int32] + [void uptr uptr] + [void int32 void*] + [void uptr void*] + [void void* void*] + [void uptr uptr uptr] + [void uptr uptr uptr uptr uptr] + [int32] + [int32 int32] + [int32 uptr] + [int32 void*] + [int32 int32 uptr] + [int32 uptr int32] + [int32 uptr uptr] + [int32 int32 int32] + [int32 int32 void*] + [int32 void* int32] + [int32 double double double double double double] + [int32 void* void* void* void* uptr] + [uint32] + [double double] + [double uptr] + [double double double] + [int32 int32] + [int32 int32 uptr] + [int32 uptr uptr uptr uptr uptr] + [uptr] + [uptr uptr] + [uptr int32] + [uptr void*] + [uptr uptr uptr] + [uptr uptr int32] + [uptr int32 uptr] + [uptr uptr int64] + [uptr uptr void*] + [uptr void* uptr] + [uptr void* int32] + [uptr void* void*] + [uptr uptr int32 int32] + [uptr uptr uptr int32] + [uptr uptr uptr uptr] + [uptr int32 int32 uptr] + [uptr void* int32 int32] + [uptr void* uptr uptr] + [uptr int32 uptr uptr uptr] + [uptr int32 int32 uptr uptr] + [uptr int32 void* uptr uptr] + [uptr uptr uptr uptr uptr] + [uptr uptr void* uptr uptr] + [uptr uptr uptr uptr uptr int32] + [uptr uptr uptr uptr uptr uptr] + [uptr void* void* void* void* uptr] + [uptr uptr int32 uptr uptr uptr uptr] + [uptr uptr uptr uptr uptr uptr uptr] + [uptr uptr uptr uptr uptr uptr uptr int32] + [uptr uptr uptr uptr uptr uptr uptr uptr] + [uptr double double double double double double] + [void*] + [void* uptr]) + + ;; end pb + ] + [else (void)]) diff --git a/s/compile.ss b/s/compile.ss index a2f908827f..2b2b04b735 100644 --- a/s/compile.ss +++ b/s/compile.ss @@ -219,6 +219,19 @@ (let ([r ($reloc (constant reloc-x86_64-popcount) n (fx- a1 ra))]) (mkc0 (cdr c*) a (cons r r*) a1 x*)))] [else (c-assembler-output-error c)])] + [(pb) + (record-case c + [(pb-abs) (n x) + (let ([a1 (fx- a 16)]) ; movz, movk, movk, movk + (let ([x* (cons (mkcode x) x*)]) + (let ([r ($reloc (constant reloc-pb-abs) n (fx- a1 ra))]) + (mkc0 (cdr c*) a (cons r r*) a1 x*))))] + [(pb-proc) (n x) + (let ([a1 (fx- a 20)]) ; movz, movk, movk, movk, b/call + (let ([x* (cons (mkcode x) x*)]) + (let ([r ($reloc (constant reloc-pb-proc) n (fx- a1 ra))]) + (mkc0 (cdr c*) a (cons r r*) a1 x*))))] + [else (c-assembler-output-error c)])] [else (c-assembler-output-error c)])])))) p))] [else (c-assembler-output-error x)])) @@ -285,6 +298,10 @@ [(ppc32) (record-case x [(ppc32-abs ppc32-call ppc32-jump) (n x) (build x d)] + [else (void)])] + [(pb) + (record-case x + [(pb-abs pb-proc) (n x) (build x d)] [else (void)])])])) code-list)])))])))) @@ -454,6 +471,17 @@ (let ([r ($reloc (constant reloc-x86_64-popcount) n (fx- a1 ra))]) (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))] [else (c-assembler-output-error c)])] + [(pb) + (record-case c + [(pb-abs) (n x) + (let ([a1 (fx- a 16)]) ; movz, movk, movk, movk + (let ([r ($reloc (constant reloc-pb-abs) n (fx- a1 ra))]) + (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))] + [(pb-proc) (n x) + (let ([a1 (fx- a 20)]) ; movz, movk, movk, movk, b/call + (let ([r ($reloc (constant reloc-pb-proc) n (fx- a1 ra))]) + (prf0 (cdr c*) a (cons r r*) a1 (cons x x*))))] + [else (c-assembler-output-error c)])] [else (c-assembler-output-error c)])]))))))] [else (c-assembler-output-error x)]))) diff --git a/s/cp0.ss b/s/cp0.ss index b6b865a3cc..d1a73eb772 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -2261,7 +2261,11 @@ (begin (residualize-seq '() '() ctxt) `(quote ,k)))])])) - (define-inline-constant-parameter (native-endianness) (constant native-endianness)) + (constant-case native-endianness + [(unknown) + (define-inline 2 (native-endianness))] + [else + (define-inline-constant-parameter (native-endianness) (constant native-endianness))]) (define-inline-constant-parameter (directory-separator) (if-feature windows #\\ #\/)) (define-inline-constant-parameter (threaded?) (if-feature pthreads #t #f)) (define-inline-constant-parameter (most-negative-fixnum least-fixnum) (constant most-negative-fixnum)) @@ -2912,6 +2916,7 @@ (define $fold-bytevector-native-ref (lambda (native-ref generic-ref align x y ctxt) (and (okay-to-handle?) + (not (eq? (constant native-endianness) 'unknown)) (visit-and-maybe-extract* bytevector? ([dx x]) (visit-and-maybe-extract* (lambda (y) (and (integer? y) diff --git a/s/cpnanopass.ss b/s/cpnanopass.ss index b2a0bb8afc..10d816631d 100644 --- a/s/cpnanopass.ss +++ b/s/cpnanopass.ss @@ -1260,7 +1260,7 @@ (syntax-case x () [(k field) #'(k ,%tc field)] [(k e-tc field) - (if (memq (field-type 'tc (datum field)) '(ptr void* uptr iptr)) + (if (memq (field-type 'tc (datum field)) '(ptr xptr uptr iptr)) (with-implicit (k %mref) #`(%mref e-tc #,(lookup-constant @@ -3547,6 +3547,13 @@ (if is-pariah? #'`(seq (pariah) body) #'`body)))))]))) + (define-syntax when-known-endianness + (lambda (stx) + (syntax-case stx () + [(_ e ...) + #'(constant-case native-endianness + [(unknown) (void)] + [else e ...])]))) (define constant? (case-lambda [(x) @@ -4005,6 +4012,7 @@ (values %zero (constant-value offset)) (values (build-unfix offset) 0)))) (define-who build-int-load + ;; assumes aligned (if required) offset (lambda (swapped? type base index offset build-int) (case type [(integer-8 unsigned-8) @@ -4012,6 +4020,7 @@ [(integer-16 integer-32 unsigned-16 unsigned-32) (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))] [(integer-64 unsigned-64) + ;; NB: doesn't handle unknown endiannesss for 32-bit machines (constant-case ptr-bits [(32) (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) @@ -4024,8 +4033,9 @@ [(64) (build-int `(inline ,(make-info-load type swapped?) ,%load ,base ,index (immediate ,offset)))])] [(integer-24 unsigned-24) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 1) offset) (values offset (+ offset 2)))]) @@ -4038,8 +4048,9 @@ (immediate 16)) (inline ,(make-info-load 'unsigned-16 swapped?) ,%load ,base ,index (immediate ,lo))))))])] [(integer-40 unsigned-40) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 1) offset) (values offset (+ offset 4)))]) @@ -4058,8 +4069,9 @@ (immediate 32)) (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] [(integer-48 unsigned-48) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 2) offset) (values offset (+ offset 4)))]) @@ -4078,8 +4090,10 @@ (immediate 32)) (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] [(integer-56 unsigned-56) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else + (safe-assert (not (eq? (constant native-endianness) 'unknown))) (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 3) (+ offset 1) offset) (values offset (+ offset 4) (+ offset 6)))]) @@ -4107,6 +4121,7 @@ (inline ,(make-info-load 'unsigned-32 swapped?) ,%load ,base ,index (immediate ,lo))))])))])] [else (sorry! who "unsupported type ~s" type)]))) (define-who build-object-ref + ;; assumes aligned (if required) offset (case-lambda [(swapped? type base offset-expr) (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) @@ -4143,7 +4158,7 @@ (bind #f (base index) (bind #t ([t (%constant-alloc type-flonum (constant size-flonum))]) (%seq - (set! ,(%mref ,t ,(constant flonum-data-disp)) + (inline ,(make-info-load 'unsigned-32 #f) ,%store ,t ,%zero ,(%constant flonum-data-disp) (inline ,(make-info-load 'unsigned-32 #t) ,%load ,base ,index (immediate ,offset))) (set! ,(%mref ,t ,%zero ,(constant flonum-data-disp) fp) @@ -4176,6 +4191,7 @@ [(fixnum) (build-fix `(inline ,(make-info-load ptr-type swapped?) ,%load ,base ,index (immediate ,offset)))] [else (sorry! who "unsupported type ~s" type)])])) (define-who build-int-store + ;; assumes aligned (if required) offset (lambda (swapped? type base index offset value) (case type [(integer-8 unsigned-8) @@ -4183,8 +4199,9 @@ [(integer-16 integer-32 integer-64 unsigned-16 unsigned-32 unsigned-64) `(inline ,(make-info-load type swapped?) ,%store ,base ,index (immediate ,offset) ,value)] [(integer-24 unsigned-24) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 1) offset) (values offset (+ offset 2)))]) @@ -4192,10 +4209,11 @@ (%seq (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,lo) ,value) (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) - ,(%inline srl ,value (immediate 16))))))])] + ,(%inline srl ,value (immediate 16))))))])] [(integer-40 unsigned-40) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 1) offset) (values offset (+ offset 4)))]) @@ -4205,8 +4223,9 @@ (inline ,(make-info-load 'unsigned-8 #f) ,%store ,base ,index (immediate ,hi) ,(%inline srl ,value (immediate 32))))))])] [(integer-48 unsigned-48) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else (let-values ([(lo hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 2) offset) (values offset (+ offset 4)))]) @@ -4216,8 +4235,9 @@ (inline ,(make-info-load 'unsigned-16 swapped?) ,%store ,base ,index (immediate ,hi) ,(%inline srl ,value (immediate 32))))))])] [(integer-56 unsigned-56) - (constant-case unaligned-integers - [(#t) + (constant-case native-endianness + [(unknown) #f] + [else (let-values ([(lo mi hi) (if (constant-case native-endianness [(little) swapped?] [(big) (not swapped?)]) (values (+ offset 3) (+ offset 1) offset) (values offset (+ offset 4) (+ offset 6)))]) @@ -4230,6 +4250,7 @@ ,(%inline srl ,value (immediate 48))))))])] [else (sorry! who "unsupported type ~s" type)]))) (define-who build-object-set! + ;; assumes aligned (if required) offset (case-lambda [(type base offset-expr value) (let-values ([(index offset) (offset-expr->index+offset offset-expr)]) @@ -4268,8 +4289,8 @@ ,base ,index (immediate ,offset) ,(%mref ,value ,(constant flonum-data-disp)))] ; 40-bit+ only on 64-bit machines - [(integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 - unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) + [(integer-8 integer-16 integer-24 integer-32 integer-40 integer-48 integer-56 integer-64 + unsigned-8 unsigned-16 unsigned-24 unsigned-32 unsigned-40 unsigned-48 unsigned-56 unsigned-64) (build-int-store #t type base index offset (ptr->integer value (type->width type)))] [(fixnum) `(inline ,(make-info-load ptr-type #t) ,%store ,base ,index (immediate ,offset) @@ -5897,120 +5918,126 @@ (inline-accessor port-name port-name-disp) (inline-accessor $thread-tc thread-tc-disp) ) - (let () - (define (build-seginfo maybe? e) - (let ([ptr (make-assigned-tmp 'ptr)] - [seginfo (make-assigned-tmp 'seginfo)]) - (define (build-level-3 seginfo k) - (constant-case segment-table-levels - [(3) - (let ([s3 (make-assigned-tmp 's3)]) - `(let ([,s3 ,(%mref ,seginfo - ,(%inline sll ,(%inline srl ,ptr (immediate ,(+ (constant segment-t1-bits) - (constant segment-t2-bits)))) - (immediate ,(constant log2-ptr-bytes))) - ,0)]) - ,(if maybe? - `(if ,(%inline eq? ,s3 (immediate 0)) - (immediate 0) - ,(k s3)) - (k s3))))] - [else (k seginfo)])) - (define (build-level-2 s3 k) - (constant-case segment-table-levels - [(2 3) - (let ([s2 (make-assigned-tmp 's2)]) - `(let ([,s2 ,(%mref ,s3 ,(%inline logand - ,(%inline srl ,ptr (immediate ,(fx- (constant segment-t1-bits) - (constant log2-ptr-bytes)))) - (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1) - (constant log2-ptr-bytes)))) - 0)]) - ,(if maybe? - `(if ,(%inline eq? ,s2 (immediate 0)) - (immediate 0) - ,(k s2)) - (k s2))))] - [else (k s3)])) - `(let ([,ptr ,(%inline srl ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) - (immediate ,(constant segment-offset-bits)))]) - (let ([,seginfo (literal ,(make-info-literal #f 'entry (lookup-c-entry segment-info) 0))]) - ,(build-level-3 seginfo - (lambda (s3) - (build-level-2 s3 - (lambda (s2) - (%mref ,s2 ,(%inline sll ,(%inline logand ,ptr - (immediate ,(fx- (fxsll 1 (constant segment-t1-bits)) 1))) - (immediate ,(constant log2-ptr-bytes))) - 0))))))))) - (define (build-space-test e space) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - (if ,(%type-check mask-immediate type-immediate ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #T e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,(let ([s `(inline ,(make-info-load 'unsigned-8 #f) ,%load ,si ,%zero (immediate 0))]) - (%inline eq? (immediate ,space) ,s)))))))) - - (define-inline 2 $maybe-seginfo - [(e) - (bind #t (e) + (constant-case architecture + [(pb) + ;; Don't try to inline seginfo access, because the C pointer size used + ;; in the table may not match the 64-bit `ptr` size + (void)] + [else + (let () + (define (build-seginfo maybe? e) + (let ([ptr (make-assigned-tmp 'ptr)] + [seginfo (make-assigned-tmp 'seginfo)]) + (define (build-level-3 seginfo k) + (constant-case segment-table-levels + [(3) + (let ([s3 (make-assigned-tmp 's3)]) + `(let ([,s3 ,(%mref ,seginfo + ,(%inline sll ,(%inline srl ,ptr (immediate ,(+ (constant segment-t1-bits) + (constant segment-t2-bits)))) + (immediate ,(constant log2-ptr-bytes))) + ,0)]) + ,(if maybe? + `(if ,(%inline eq? ,s3 (immediate 0)) + (immediate 0) + ,(k s3)) + (k s3))))] + [else (k seginfo)])) + (define (build-level-2 s3 k) + (constant-case segment-table-levels + [(2 3) + (let ([s2 (make-assigned-tmp 's2)]) + `(let ([,s2 ,(%mref ,s3 ,(%inline logand + ,(%inline srl ,ptr (immediate ,(fx- (constant segment-t1-bits) + (constant log2-ptr-bytes)))) + (immediate ,(fxsll (fx- (fxsll 1 (constant segment-t2-bits)) 1) + (constant log2-ptr-bytes)))) + 0)]) + ,(if maybe? + `(if ,(%inline eq? ,s2 (immediate 0)) + (immediate 0) + ,(k s2)) + (k s2))))] + [else (k s3)])) + `(let ([,ptr ,(%inline srl ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) + (immediate ,(constant segment-offset-bits)))]) + (let ([,seginfo (literal ,(make-info-literal #f 'entry (lookup-c-entry segment-info) 0))]) + ,(build-level-3 seginfo + (lambda (s3) + (build-level-2 s3 + (lambda (s2) + (%mref ,s2 ,(%inline sll ,(%inline logand ,ptr + (immediate ,(fx- (fxsll 1 (constant segment-t1-bits)) 1))) + (immediate ,(constant log2-ptr-bytes))) + 0))))))))) + (define (build-space-test e space) `(if ,(%type-check mask-fixnum type-fixnum ,e) ,(%constant sfalse) (if ,(%type-check mask-immediate type-immediate ,e) ,(%constant sfalse) - ,(let ([s-e (build-seginfo #t e)] + ,(let ([s-e (build-seginfo #T e)] [si (make-assigned-tmp 'si)]) `(let ([,si ,s-e]) (if ,(%inline eq? ,si (immediate 0)) ,(%constant sfalse) - ,si))))))]) - (define-inline 2 $seginfo - [(e) - (bind #t (e) (build-seginfo #f e))]) - (define-inline 2 $seginfo-generation - [(e) - (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))]) - (define-inline 2 $seginfo-space - [(e) - (bind #f (e) - (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-space-disp)))]) - (define-inline 2 $list-bits-ref - [(e) - (bind #t (e) - (let ([si (make-assigned-tmp 'si)] - [list-bits (make-assigned-tmp 'list-bits)] - [offset (make-assigned-tmp 'offset)] - [byte (make-assigned-tmp 'byte)]) - `(let ([,si ,(build-seginfo #f e)]) - (let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))]) - (if ,(%inline eq? ,list-bits (immediate 0)) - (immediate 0) - (let ([,offset ,(%inline srl ,(%inline logand ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) - (immediate ,(fx- (constant bytes-per-segment) 1))) - (immediate ,(constant log2-ptr-bytes)))]) - (let ([,byte (inline ,(make-info-load 'unsigned-8 #f) ,%load ,list-bits ,%zero ,(%inline srl ,offset (immediate 3)))]) - ,(build-fix (%inline logand ,(%inline srl ,byte ,(%inline logand ,offset (immediate 7))) - (immediate ,(constant list-bits-mask)))))))))))]) - (define-inline 2 $generation - [(e) - (bind #t (e) - `(if ,(%type-check mask-fixnum type-fixnum ,e) - ,(%constant sfalse) - ,(let ([s-e (build-seginfo #t e)] - [si (make-assigned-tmp 'si)]) - `(let ([,si ,s-e]) - (if ,(%inline eq? ,si (immediate 0)) - ,(%constant sfalse) - ,(build-object-ref #f 'unsigned-8 si %zero 1))))))]) - (define-inline 2 weak-pair? - [(e) (bind #t (e) (build-space-test e (constant space-weakpair)))]) - (define-inline 2 ephemeron-pair? - [(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))])) + ,(let ([s `(inline ,(make-info-load 'unsigned-8 #f) ,%load ,si ,%zero (immediate 0))]) + (%inline eq? (immediate ,space) ,s)))))))) + + (define-inline 2 $maybe-seginfo + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + (if ,(%type-check mask-immediate type-immediate ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #t e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,si))))))]) + (define-inline 2 $seginfo + [(e) + (bind #t (e) (build-seginfo #f e))]) + (define-inline 2 $seginfo-generation + [(e) + (bind #f (e) (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-generation-disp)))]) + (define-inline 2 $seginfo-space + [(e) + (bind #f (e) + (build-object-ref #f 'unsigned-8 e %zero (constant seginfo-space-disp)))]) + (define-inline 2 $list-bits-ref + [(e) + (bind #t (e) + (let ([si (make-assigned-tmp 'si)] + [list-bits (make-assigned-tmp 'list-bits)] + [offset (make-assigned-tmp 'offset)] + [byte (make-assigned-tmp 'byte)]) + `(let ([,si ,(build-seginfo #f e)]) + (let ([,list-bits ,(%mref ,si ,(constant seginfo-list-bits-disp))]) + (if ,(%inline eq? ,list-bits (immediate 0)) + (immediate 0) + (let ([,offset ,(%inline srl ,(%inline logand ,(%inline + ,e (immediate ,(fx- (constant typemod) 1))) + (immediate ,(fx- (constant bytes-per-segment) 1))) + (immediate ,(constant log2-ptr-bytes)))]) + (let ([,byte (inline ,(make-info-load 'unsigned-8 #f) ,%load ,list-bits ,%zero ,(%inline srl ,offset (immediate 3)))]) + ,(build-fix (%inline logand ,(%inline srl ,byte ,(%inline logand ,offset (immediate 7))) + (immediate ,(constant list-bits-mask)))))))))))]) + (define-inline 2 $generation + [(e) + (bind #t (e) + `(if ,(%type-check mask-fixnum type-fixnum ,e) + ,(%constant sfalse) + ,(let ([s-e (build-seginfo #t e)] + [si (make-assigned-tmp 'si)]) + `(let ([,si ,s-e]) + (if ,(%inline eq? ,si (immediate 0)) + ,(%constant sfalse) + ,(build-object-ref #f 'unsigned-8 si %zero 1))))))]) + (define-inline 2 weak-pair? + [(e) (bind #t (e) (build-space-test e (constant space-weakpair)))]) + (define-inline 2 ephemeron-pair? + [(e) (bind #t (e) (build-space-test e (constant space-ephemeron)))]))]) (define-inline 2 unbox [(e) @@ -6541,8 +6568,11 @@ [() `(quote ,(constant most-positive-fixnum))]) (define-inline 2 fixnum-width [() `(quote ,(constant fixnum-bits))]) - (define-inline 2 native-endianness - [() `(quote ,(constant native-endianness))]) + (constant-case native-endianness + [(unknown) (void)] + [else + (define-inline 2 native-endianness + [() `(quote ,(constant native-endianness))])]) (define-inline 2 directory-separator [() `(quote ,(if-feature windows #\\ #\/))]) (let () ; level 2 char=?, r6rs:char=?, etc. @@ -6793,6 +6823,7 @@ ;; Non-NaN: compare bits (constant-case ptr-bits [(32) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) (let ([d0 (if (eq? (constant native-endianness) (native-endianness)) 0 4)]) (let ([word1 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) d0))] [word2 ($object-ref 'integer-32 d (fx+ (constant flonum-data-disp) (fx- 4 d0)))]) @@ -7553,10 +7584,18 @@ (let ([cnt (- pos (constant fixnum-offset))] [mask (* (- (expt 2 size) 1) (expt 2 (constant fixnum-offset)))]) (%inline logand - ,(let ([body `(inline ,(make-info-load 'integer-32 #f) ,%load ,e1 ,%zero - (immediate ,(constant-case native-endianness - [(little) (fx+ (constant flonum-data-disp) 4)] - [(big) (constant flonum-data-disp)])))]) + ,(let ([body (constant-case native-endianness + [(unknown) + (constant-case ptr-bits + [(64) + (%inline srl ,(%mref ,e1 ,(constant flonum-data-disp)) (immediate 32))] + [(32) + (inline ,(make-info-unboxed-args '(#t)) ,%fpcastto/hi ,e)])] + [else + `(inline ,(make-info-load 'integer-32 #f) ,%load ,e1 ,%zero + (immediate ,(constant-case native-endianness + [(little) (fx+ (constant flonum-data-disp) 4)] + [(big) (constant flonum-data-disp)])))])]) (let ([body (if (fx> cnt 0) (%inline srl ,body (immediate ,cnt)) body)]) @@ -7657,7 +7696,7 @@ (define-inline 3 flsqrt [(e) (constant-case architecture - [(x86 x86_64 arm32 arm64) (build-fp-op-1 %fpsqrt e)] + [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])]) (define-inline 3 flabs @@ -8001,7 +8040,7 @@ (build-checked-fp-op e (lambda (e) (constant-case architecture - [(x86 x86_64 arm32 arm64) (build-fp-op-1 %fpsqrt e)] + [(x86 x86_64 arm32 arm64 pb) (build-fp-op-1 %fpsqrt e)] [(ppc32) (build-fl-call (lookup-c-entry flsqrt) e)])) (lambda (e) (build-libcall #t src sexpr flsqrt e)))]) @@ -8137,6 +8176,18 @@ (ptr->integer e-addr (constant ptr-bits)) e-offset))))] [else #f])]) + (define-inline 3 $foreign-swap-ref + [(e-type e-addr e-offset) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean))) + (bind #f (e-offset) + (build-object-ref #t type + (ptr->integer e-addr (constant ptr-bits)) + e-offset))))] + [else #f])]) (define-inline 2 $object-set! [(type base offset value) (nanopass-case (L7 Expr) type @@ -8161,6 +8212,20 @@ e-offset e-value))))] [else #f])]) + (define-inline 3 $foreign-swap-set! + [(e-type e-addr e-offset e-value) + (nanopass-case (L7 Expr) e-type + [(quote ,d) + (let ([type (filter-foreign-type d)]) + (and (memq type (record-datatype list)) + (not (memq type '(char wchar boolean single-float))) + (>= (constant ptr-bits) (type->width type)) + (bind #f (e-offset e-value) + (build-swap-object-set! type + (ptr->integer e-addr (constant ptr-bits)) + e-offset + e-value))))] + [else #f])]) (define-inline 2 $make-fptr [(e-ftype e-addr) (nanopass-case (L7 Expr) e-addr @@ -8303,30 +8368,32 @@ (define-fptr-ref-inline $fptr-ref-swap-integer-16 'integer-16 #t) (define-fptr-ref-inline $fptr-ref-swap-unsigned-16 'unsigned-16 #t) - (define-fptr-ref-inline $fptr-ref-integer-24 'integer-24 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-24 'unsigned-24 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-24 'integer-24 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-24 'unsigned-24 #t) + (when-known-endianness + (define-fptr-ref-inline $fptr-ref-integer-24 'integer-24 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-24 'unsigned-24 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-24 'integer-24 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-24 'unsigned-24 #t)) (define-fptr-ref-inline $fptr-ref-integer-32 'integer-32 #f) (define-fptr-ref-inline $fptr-ref-unsigned-32 'unsigned-32 #f) (define-fptr-ref-inline $fptr-ref-swap-integer-32 'integer-32 #t) (define-fptr-ref-inline $fptr-ref-swap-unsigned-32 'unsigned-32 #t) - (define-fptr-ref-inline $fptr-ref-integer-40 'integer-40 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-40 'unsigned-40 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-40 'integer-40 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-40 'unsigned-40 #t) + (when-known-endianness + (define-fptr-ref-inline $fptr-ref-integer-40 'integer-40 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-40 'unsigned-40 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-40 'integer-40 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-40 'unsigned-40 #t) - (define-fptr-ref-inline $fptr-ref-integer-48 'integer-48 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-48 'unsigned-48 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-48 'integer-48 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-48 'unsigned-48 #t) - - (define-fptr-ref-inline $fptr-ref-integer-56 'integer-56 #f) - (define-fptr-ref-inline $fptr-ref-unsigned-56 'unsigned-56 #f) - (define-fptr-ref-inline $fptr-ref-swap-integer-56 'integer-56 #t) - (define-fptr-ref-inline $fptr-ref-swap-unsigned-56 'unsigned-56 #t) + (define-fptr-ref-inline $fptr-ref-integer-48 'integer-48 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-48 'unsigned-48 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-48 'integer-48 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-48 'unsigned-48 #t) + + (define-fptr-ref-inline $fptr-ref-integer-56 'integer-56 #f) + (define-fptr-ref-inline $fptr-ref-unsigned-56 'unsigned-56 #f) + (define-fptr-ref-inline $fptr-ref-swap-integer-56 'integer-56 #t) + (define-fptr-ref-inline $fptr-ref-swap-unsigned-56 'unsigned-56 #t)) (define-fptr-ref-inline $fptr-ref-integer-64 'integer-64 #f) (define-fptr-ref-inline $fptr-ref-unsigned-64 'unsigned-64 #f) @@ -8403,30 +8470,32 @@ (define-fptr-set!-inline #f $fptr-set-swap-integer-16! 'integer-16 build-swap-object-set!) (define-fptr-set!-inline #f $fptr-set-swap-unsigned-16! 'unsigned-16 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-integer-24! 'integer-24 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-unsigned-24! 'unsigned-24 build-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-integer-24! 'integer-24 build-swap-object-set!) - (define-fptr-set!-inline #f $fptr-set-swap-unsigned-24! 'unsigned-24 build-swap-object-set!) + (when-known-endianness + (define-fptr-set!-inline #f $fptr-set-integer-24! 'integer-24 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-unsigned-24! 'unsigned-24 build-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-integer-24! 'integer-24 build-swap-object-set!) + (define-fptr-set!-inline #f $fptr-set-swap-unsigned-24! 'unsigned-24 build-swap-object-set!)) (define-fptr-set!-inline #f $fptr-set-integer-32! 'integer-32 build-object-set!) (define-fptr-set!-inline #f $fptr-set-unsigned-32! 'unsigned-32 build-object-set!) (define-fptr-set!-inline #f $fptr-set-swap-integer-32! 'integer-32 build-swap-object-set!) (define-fptr-set!-inline #f $fptr-set-swap-unsigned-32! 'unsigned-32 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-integer-40! 'integer-40 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-40! 'unsigned-40 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-40! 'integer-40 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-40! 'unsigned-40 build-swap-object-set!) + (when-known-endianness + (define-fptr-set!-inline #t $fptr-set-integer-40! 'integer-40 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-40! 'unsigned-40 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-40! 'integer-40 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-40! 'unsigned-40 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-integer-48! 'integer-48 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-48! 'unsigned-48 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-48! 'integer-48 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-48! 'unsigned-48 build-swap-object-set!) - - (define-fptr-set!-inline #t $fptr-set-integer-56! 'integer-56 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-unsigned-56! 'unsigned-56 build-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-integer-56! 'integer-56 build-swap-object-set!) - (define-fptr-set!-inline #t $fptr-set-swap-unsigned-56! 'unsigned-56 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-integer-48! 'integer-48 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-48! 'unsigned-48 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-48! 'integer-48 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-48! 'unsigned-48 build-swap-object-set!) + + (define-fptr-set!-inline #t $fptr-set-integer-56! 'integer-56 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-unsigned-56! 'unsigned-56 build-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-integer-56! 'integer-56 build-swap-object-set!) + (define-fptr-set!-inline #t $fptr-set-swap-unsigned-56! 'unsigned-56 build-swap-object-set!)) (define-fptr-set!-inline #t $fptr-set-integer-64! 'integer-64 build-object-set!) (define-fptr-set!-inline #t $fptr-set-unsigned-64! 'unsigned-64 build-object-set!) @@ -8495,30 +8564,32 @@ (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-16 #t unsigned-16 #t) (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-16 #f unsigned-16 #t) - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-24 #t unsigned-24 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-24 #f unsigned-24 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-24 #t unsigned-24 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-24 #f unsigned-24 #t) + (when-known-endianness + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-24 #t unsigned-24 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-24 #f unsigned-24 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-24 #t unsigned-24 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-24 #f unsigned-24 #t)) (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-32 #t unsigned-32 #f) (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-32 #f unsigned-32 #f) (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-32 #t unsigned-32 #t) (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-32 #f unsigned-32 #t) - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-40 #t unsigned-40 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-40 #f unsigned-40 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-40 #t unsigned-40 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-40 #f unsigned-40 #t) + (when-known-endianness + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-40 #t unsigned-40 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-40 #f unsigned-40 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-40 #t unsigned-40 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-40 #f unsigned-40 #t) - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-48 #t unsigned-48 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-48 #f unsigned-48 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-48 #t unsigned-48 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-48 #f unsigned-48 #t) + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-48 #t unsigned-48 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-48 #f unsigned-48 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-48 #t unsigned-48 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-48 #f unsigned-48 #t) - (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-56 #t unsigned-56 #f) - (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-56 #f unsigned-56 #f) - (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-56 #t unsigned-56 #t) - (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-56 #f unsigned-56 #t) + (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-56 #t unsigned-56 #f) + (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-56 #f unsigned-56 #f) + (define-fptr-bits-ref-inline $fptr-ref-ibits-swap-unsigned-56 #t unsigned-56 #t) + (define-fptr-bits-ref-inline $fptr-ref-ubits-swap-unsigned-56 #f unsigned-56 #t)) (define-fptr-bits-ref-inline $fptr-ref-ibits-unsigned-64 #t unsigned-64 #f) (define-fptr-bits-ref-inline $fptr-ref-ubits-unsigned-64 #f unsigned-64 #f) @@ -8556,20 +8627,22 @@ (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-16! unsigned-16 #f) (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-16! unsigned-16 #t) - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-24! unsigned-24 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-24! unsigned-24 #t) + (when-known-endianness + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-24! unsigned-24 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-24! unsigned-24 #t)) (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-32! unsigned-32 #f) (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-32! unsigned-32 #t) - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-40! unsigned-40 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-40! unsigned-40 #t) + (when-known-endianness + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-40! unsigned-40 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-40! unsigned-40 #t) - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-48! unsigned-48 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-48! unsigned-48 #t) + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-48! unsigned-48 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-48! unsigned-48 #t) - (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-56! unsigned-56 #f) - (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-56! unsigned-56 #t) + (define-fptr-bits-set-inline #f $fptr-set-bits-unsigned-56! unsigned-56 #f) + (define-fptr-bits-set-inline #f $fptr-set-bits-swap-unsigned-56! unsigned-56 #t)) (define-fptr-bits-set-inline #t $fptr-set-bits-unsigned-64! unsigned-64 #f) (define-fptr-bits-set-inline #t $fptr-set-bits-swap-unsigned-64! unsigned-64 #t)) @@ -9387,23 +9460,29 @@ (define build-bytevector (lambda (e*) (define (find-k n) - (let loop ([bytes (constant-case ptr-bits [(32) 4] [(64) 8])] - [type* (constant-case ptr-bits - [(32) '(unsigned-32 unsigned-16 unsigned-8)] - [(64) '(unsigned-64 unsigned-32 unsigned-16 unsigned-8)])]) - (let ([bytes/2 (fxsrl bytes 1)]) - (if (fx<= n bytes/2) - (loop bytes/2 (cdr type*)) - (values bytes (car type*)))))) + (constant-case native-endianness + [(unknown) + (values 1 'unsigned-8)] + [else + (let loop ([bytes (constant-case ptr-bits [(32) 4] [(64) 8])] + [type* (constant-case ptr-bits + [(32) '(unsigned-32 unsigned-16 unsigned-8)] + [(64) '(unsigned-64 unsigned-32 unsigned-16 unsigned-8)])]) + (let ([bytes/2 (fxsrl bytes 1)]) + (if (fx<= n bytes/2) + (loop bytes/2 (cdr type*)) + (values bytes (car type*)))))])) (define (build-chunk k n e*) (define (build-shift e shift) (if (fx= shift 0) e (%inline sll ,e (immediate ,shift)))) (let loop ([k (constant-case native-endianness [(little) (fxmin k n)] - [(big) k])] + [(big) k] + [(unknown) (safe-assert (= k 1)) 1])] [e* (constant-case native-endianness [(little) (reverse (if (fx<= n k) e* (list-head e* k)))] - [(big) e*])] + [(big) e*] + [(unknown) e*])] [constant-part 0] [expression-part #f] [expression-shift 0] @@ -9642,20 +9721,22 @@ (define-bv-int-ref-inline bytevector-s16-ref integer-16 1) (define-bv-int-ref-inline bytevector-u16-ref unsigned-16 1) - (define-bv-int-ref-inline bytevector-s24-ref integer-24 1) - (define-bv-int-ref-inline bytevector-u24-ref unsigned-24 1) + (when-known-endianness + (define-bv-int-ref-inline bytevector-s24-ref integer-24 1) + (define-bv-int-ref-inline bytevector-u24-ref unsigned-24 1)) (define-bv-int-ref-inline bytevector-s32-ref integer-32 3) (define-bv-int-ref-inline bytevector-u32-ref unsigned-32 3) - (define-bv-int-ref-inline bytevector-s40-ref integer-40 3) - (define-bv-int-ref-inline bytevector-u40-ref unsigned-40 3) + (when-known-endianness + (define-bv-int-ref-inline bytevector-s40-ref integer-40 3) + (define-bv-int-ref-inline bytevector-u40-ref unsigned-40 3) - (define-bv-int-ref-inline bytevector-s48-ref integer-48 3) - (define-bv-int-ref-inline bytevector-u48-ref unsigned-48 3) + (define-bv-int-ref-inline bytevector-s48-ref integer-48 3) + (define-bv-int-ref-inline bytevector-u48-ref unsigned-48 3) - (define-bv-int-ref-inline bytevector-s56-ref integer-56 7) - (define-bv-int-ref-inline bytevector-u56-ref unsigned-56 7) + (define-bv-int-ref-inline bytevector-s56-ref integer-56 7) + (define-bv-int-ref-inline bytevector-u56-ref unsigned-56 7)) (define-bv-int-ref-inline bytevector-s64-ref integer-64 7) (define-bv-int-ref-inline bytevector-u64-ref unsigned-64 7)) @@ -9669,6 +9750,7 @@ [(e-bv e-offset e-eness) (and (or (constant unaligned-floats) (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) (build-object-ref #f 'type e-bv e-index imm-offset)))])]))) @@ -9683,6 +9765,7 @@ [(_ check-64? name type mask) (with-syntax ([body #'(and (or (constant unaligned-integers) (and mask (bv-offset-okay? e-offset mask))) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) (constant? (lambda (x) (memq x '(big little))) e-eness) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) (if (eq? (constant-value e-eness) (constant native-endianness)) @@ -9723,6 +9806,7 @@ #'(define-inline 3 name [(e-bv e-offset e-value e-eness) (and (or (constant unaligned-floats) (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) (constant? (lambda (x) (eq? x (constant native-endianness))) e-eness) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) (bind #f (e-bv e-index) @@ -9738,6 +9822,7 @@ (lambda (type mask e-bv e-offset e-eness) (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) (constant? (lambda (x) (memq x '(big little))) e-eness) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) (build-object-ref (not (eq? (constant-value e-eness) (constant native-endianness))) type e-bv e-index imm-offset))))) @@ -9766,6 +9851,7 @@ (define anyint-set!-helper (lambda (type mask e-bv e-offset e-value e-eness) (and (or (constant unaligned-integers) (bv-offset-okay? e-offset mask)) + (safe-assert (not (eq? (constant native-endianness) 'unknown))) (constant? (lambda (x) (memq x '(big little))) e-eness) (let-values ([(e-index imm-offset) (bv-index-offset e-offset)]) (if (eq? (constant-value e-eness) (constant native-endianness)) @@ -10658,7 +10744,7 @@ ,(unsigned->ptr (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) 64))] - [(arm32) (unsigned->ptr (%inline read-time-stamp-counter) 32)] + [(arm32 pb) (unsigned->ptr (%inline read-time-stamp-counter) 32)] [(arm64) (unsigned->ptr (%inline read-time-stamp-counter) 64)] [(ppc32) (let ([t-hi (make-tmp 't-hi)]) @@ -10679,7 +10765,7 @@ ,(unsigned->ptr (%inline logor ,(%inline sll ,%rdx (immediate 32)) ,%rax) 64))] - [(arm32 ppc32) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)] + [(arm32 ppc32 pb) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 32)] [(arm64) (unsigned->ptr (%inline read-performance-monitoring-counter ,(build-unfix e)) 64)])]) )) ; expand-primitives module @@ -14296,6 +14382,7 @@ (set! ,bv2 ,(%mref ,bv2 ,(constant bytevector-data-disp))) (set! ,idx ,(%inline - ,iptr-bytes ,idx)) (set! ,idx ,(%inline sll ,idx (immediate 3))) + ;; idx is the number of bits we want to discard ,(constant-case native-endianness [(little) (%seq @@ -14304,7 +14391,11 @@ [(big) (%seq (set! ,bv1 ,(%inline srl ,bv1 ,idx)) - (set! ,bv2 ,(%inline srl ,bv2 ,idx)))]) + (set! ,bv2 ,(%inline srl ,bv2 ,idx)))] + [(unknown) + (%seq + (set! ,bv1 ,(%inline slol ,bv1 ,idx)) + (set! ,bv2 ,(%inline slol ,bv2 ,idx)))]) ,(%inline eq? ,bv1 ,bv2))) ,(%seq (label ,Ltrue) @@ -17764,7 +17855,6 @@ (let ([spillable-live (live-info-live live-info)]) (if (unspillable? x) (let ([unspillable* (remq x unspillable*)]) - (unless (uvar-seen? x) (#%printf ">> ~s\n" x)) (safe-assert (uvar-seen? x)) (uvar-seen! x #f) (if (and (var? rhs) (var-index rhs)) diff --git a/s/fasl-helpers.ss b/s/fasl-helpers.ss index a2c27cef3c..e45fdce123 100644 --- a/s/fasl-helpers.ss +++ b/s/fasl-helpers.ss @@ -34,7 +34,7 @@ [else ($oops 'put16-be "unsupported fixnum size")])) (define put16 (lambda (p n) - (constant-case native-endianness + (constant-case fasl-endianness [(little) (put16-le p n)] [(big) (put16-be p n)]))) (define put32-le @@ -87,7 +87,7 @@ [else ($oops 'put32-be "unsupported fixnum size")])) (define put32 (lambda (p n) - (constant-case native-endianness + (constant-case fasl-endianness [(little) (put32-le p n)] [(big) (put32-be p n)]))) (define put64-le @@ -110,7 +110,7 @@ (put32-be p (logand n (bit-mask 32)))]))) (define put64 (lambda (p n) - (constant-case native-endianness + (constant-case fasl-endianness [(little) (put64-le p n)] [(big) (put64-be p n)]))) (define put-iptr diff --git a/s/ftype.ss b/s/ftype.ss index fea18e0381..c344b70167 100644 --- a/s/ftype.ss +++ b/s/ftype.ss @@ -68,7 +68,7 @@ signedness -> signed | unsigned bits -> exact positive integer -endianness -> native | big | little +endianness -> native | big | little | swapped built-in ftype names: short | unsigned-short @@ -316,14 +316,14 @@ ftype operators: (record-predicate rtd)) #,@(ftd-accessors #'record-name #'(field ...))))]))) - (define-ftd-record-type base #{rtd/ftd-base a9pth58056u34h517jsrqv-8} swap? type) + (define-ftd-record-type base #{rtd/ftd-base a9pth58056u34h517jsrqv-18} eness type) (define-ftd-record-type struct #{rtd/ftd-struct a9pth58056u34h517jsrqv-3} field*) (define-ftd-record-type union #{rtd/ftd-union a9pth58056u34h517jsrqv-4} field*) (define-ftd-record-type array #{rtd/ftd-array a9pth58056u34h517jsrqv-5} length ftd) (define-ftd-record-type pointer #{rtd/ftd-pointer a9pth58056u34h517jsrqv-6} (mutable ftd)) - (define-ftd-record-type bits #{rtd/ftd-ibits a9pth58056u34h517jsrqv-9} swap? field*) + (define-ftd-record-type bits #{rtd/ftd-ibits a9pth58056u34h517jsrqv-19} eness field*) (define-ftd-record-type function #{rtd/ftd-function a9pth58056u34h517jsrqv-11} conv* arg-type* result-type) - (module (pointer-size alignment pointer-alignment native-base-ftds swap-base-ftds) + (module (pointer-size alignment pointer-alignment native-base-ftds swap-base-ftds big-base-ftds little-base-ftds) (define alignment (lambda (max-alignment size) (gcd max-alignment size))) @@ -337,13 +337,21 @@ ftype operators: integer-40 unsigned-40 integer-48 unsigned-48 integer-56 unsigned-56 integer-64 unsigned-64 single-float double-float wchar_t size_t ssize_t ptrdiff_t)) (define-who mfb - (lambda (swap?) + (lambda (eness) (lambda (ty) (define-syntax make (syntax-rules () [(_ type bytes pred) - (if (and swap? (fx= bytes 1)) - (find (lambda (ftd) (eq? (ftd-base-type ftd) ty)) native-base-ftds) + (cond + [(or (and (not (eq? eness 'native)) (fx= bytes 1)) + (eq? (constant native-endianness) eness)) + (find (lambda (ftd) (eq? (ftd-base-type ftd) ty)) native-base-ftds)] + [(or (and (eq? eness 'little) + (eq? (constant native-endianness) 'big)) + (and (eq? eness 'big) + (eq? (constant native-endianness) 'little))) + (find (lambda (ftd) (eq? (ftd-base-type ftd) ty)) swap-base-ftds)] + [else (make-ftd-base rtd/fptr ; creating static gensym so base ftypes are nongenerative to support ; separate compilation of ftype definitions and uses. creating unique @@ -352,20 +360,23 @@ ftype operators: ; a different rtd/ftd with the correct "extras" (including size and ; alignment) when cross compiling between machines with different ; base-type characteristics. - (let ([pname (format "~a~:[~;s~]" ty swap?)]) + (let ([pname (format "~a~a" ty (case eness + [(native) ""] + [(swapped) "s"] + [(big) "b"] + [(little) "l"]))]) (let ([gstring (format "~aa9pth58056u34h517jsrqv-~s-~a" pname (constant machine-type-name) pname)]) ($intern3 gstring (string-length pname) (string-length gstring)))) - (if swap? - `(endian ,(constant-case native-endianness - [(big) 'little] - [(little) 'big]) - ,ty) - ty) - bytes (alignment (if (memq 'type '(single-float double-float)) (constant max-float-alignment) (constant max-integer-alignment)) bytes) swap? ty))])) + (if (eq? eness 'native) + ty + `(endian ,eness ,ty)) + bytes (alignment (if (memq 'type '(single-float double-float)) (constant max-float-alignment) (constant max-integer-alignment)) bytes) eness ty)])])) (record-datatype cases (filter-foreign-type ty) make ($oops who "unrecognized type ~s" ty))))) - (define native-base-ftds (map (mfb #f) base-types)) - (define swap-base-ftds (map (mfb #t) base-types))) + (define native-base-ftds (map (mfb 'native) base-types)) + (define swap-base-ftds (map (mfb 'swapped) base-types)) + (define big-base-ftds (map (mfb 'big) base-types)) + (define little-base-ftds (map (mfb 'little) base-types))) (define expand-field-names (lambda (x*) (let f ([x* x*] [seen* '()]) @@ -404,7 +415,7 @@ ftype operators: (syntax-error ftype "non-fixnum overall size for ftype")))) ftd) (check-size - (let f/flags ([ftype ftype] [defid defid] [stype (syntax->datum ftype)] [packed? #f] [swap? #f] [funok? #t]) + (let f/flags ([ftype ftype] [defid defid] [stype (syntax->datum ftype)] [packed? #f] [eness 'native] [funok? #t]) (define (pad n k) (if packed? n (logand (+ n (- k 1)) (- k)))) (let f ([ftype ftype] [defid defid] [stype stype] [funok? funok?]) (if (identifier? ftype) @@ -427,7 +438,12 @@ ftype operators: ftd)] [(find (let ([x (syntax->datum ftype)]) (lambda (ftd) (eq? (ftd-base-type ftd) x))) - (if swap? swap-base-ftds native-base-ftds))] + (case eness + [(native) native-base-ftds] + [(swapped) swap-base-ftds] + [(big) big-base-ftds] + [(little) little-base-ftds] + [else (error 'eness "unexpected ~s" eness)]))] [else (syntax-error ftype "unrecognized ftype name")]) (syntax-case ftype () [(struct-kwd (field-name ftype) ...) @@ -493,19 +509,26 @@ ftype operators: (syntax-error (car bits*) "invalid bit-field bit count")) (let-values ([(bit-size field*) (f (cdr id*) (cdr s*) (cdr bits*) (+ bit-offset bits))]) (values bit-size - (let ([start (if (eq? (native-endianness) (if swap? 'little 'big)) + (let ([start (if (or (eq? eness 'big) + (and (eq? eness 'native) + (eq? (constant native-endianness) 'big)) + (and (eq? eness 'swapped) + (eq? (constant native-endianness) 'little))) (- bit-size bit-offset bits) bit-offset)]) (cons (list (car id*) (signed? (car s*)) start (+ start bits)) field*))))))))) + (when (and (eq? (constant native-endianness) 'unknown) + (not (or (eq? eness 'little) (eq? eness 'big)))) + (syntax-error ftype "bit fields require a specific endianness")) (let-values ([(bit-size field*) (parse-fields)]) (unless (memq bit-size '(8 16 24 32 40 48 56 64)) (syntax-error ftype "bit counts do not add up to 8, 16, 32, or 64")) - (let ([offset (fxsrl bit-size 3)]) - (make-ftd-bits rtd/fptr - (and defid (symbol->string (syntax->datum defid))) - stype offset (alignment (constant max-integer-alignment) offset) - (and swap? (fx> offset 1)) field*))))] + (let ([offset (fxsrl bit-size 3)]) + (make-ftd-bits rtd/fptr + (and defid (symbol->string (syntax->datum defid))) + stype offset (alignment (constant max-integer-alignment) offset) + eness field*))))] [(*-kwd ftype) (eq? (datum *-kwd) '*) (cond @@ -544,18 +567,23 @@ ftype operators: (filter-type r #'result-type #t)))] [(packed-kwd ftype) (eq? (datum packed-kwd) 'packed) - (f/flags #'ftype #f stype #t swap? funok?)] + (f/flags #'ftype #f stype #t eness funok?)] [(unpacked-kwd ftype) (eq? (datum unpacked-kwd) 'unpacked) - (f/flags #'ftype #f stype #f swap? funok?)] + (f/flags #'ftype #f stype #f eness funok?)] [(endian-kwd ?eness ftype) (eq? (datum endian-kwd) 'endian) - (let ([eness (datum ?eness)]) - (unless (memq eness '(big little native)) + (let ([new-eness (datum ?eness)]) + (unless (memq new-eness '(big little native swapped)) (syntax-error #'?eness "invalid endianness")) - (let ([swap? (and (not (eq? eness 'native)) - (not (eq? eness (constant native-endianness))))]) - (f/flags #'ftype #f stype packed? swap? funok?)))] + (let ([eness (case new-eness + [(swapped) (case eness + [(little) 'big] + [(big) 'little] + [(native) 'swapped] + [(swapped) 'native])] + [else new-eness])]) + (f/flags #'ftype #f stype packed? eness funok?)))] [_ (syntax-error ftype "invalid ftype")])))))])) (define expand-fp-ftype (lambda (who what r ftype def-alist) @@ -591,8 +619,8 @@ ftype operators: (lambda (ftd) (unless (ftd-base? ftd) (syntax-error ftype (format "invalid (non-base) ~s ~s ftype" who what))) - (when (ftd-base-swap? ftd) - (syntax-error ftype (format "invalid (swapped) ~s ~s ftype" who what))) + (unless (eq? (ftd-base-eness ftd) 'native) + (syntax-error ftype (format "invalid (not native) ~s ~s ftype" who what))) (ftd-base-type ftd))] [else (syntax->datum ftype)])]))) (define-who indirect-ftd-pointer @@ -669,6 +697,56 @@ ftype operators: (lambda (pargs->new) (lambda (whoid expr ftd pointer?) ((pargs->new expr) (syntax->datum whoid) ftd pointer?))))) + + (define-syntax use-foreign + (syntax-rules () + [(_ op type info fptr offset val) + (op 'type ($ftype-pointer-address fptr) offset val)] + [(_ op type fptr offset) + (op 'type ($ftype-pointer-address fptr) offset)])) + (define-syntax multi-int + (syntax-rules () + [(_ op type (fast-op arg ...)) + (constant-case native-endianness + [(unknown) (use-foreign op type arg ...)] + [else (fast-op arg ...)])])) + (define-syntax wide + (syntax-rules () + [(_ op type (fast-op arg ...)) + (constant-case ptr-bits + [(64) (fast-op arg ...)] + [(32) (use-foreign op type arg ...)])])) + (define-syntax multi-int/wide + (syntax-rules () + [(_ op type (fast-op arg ...)) + (constant-case ptr-bits + [(64) (multi-int op type (fast-op arg ...))] + [(32) (use-foreign op type arg ...)])])) + (define-syntax swapped-endianness + (lambda (stx) + (syntax-case stx () + [(_) + (constant-case native-endianness + [(little) #''big] + [(big) #''little] + [(unknown) #'(if (eq? (native-endianness) 'little) + 'big + 'little)])]))) + (define simplify-eness + (lambda (eness type) + (case type + [(integer-8 unsigned-8) 'native] + [else + (case eness + [(little) (constant-case native-endianness + [(big) 'swapped] + [(little) 'native] + [else eness])] + [(big) (constant-case native-endianness + [(big) 'native] + [(little) 'swapped] + [else eness])] + [else eness])]))) (record-writer rtd/ftd (lambda (x p wr) (fprintf p "#" (record-type-name x)))) @@ -868,7 +946,7 @@ ftype operators: (if id `(,id ,(guard (c [#t 'invalid]) - ($fptr-ref-bits type (ftd-bits-swap? ftd) signed? + ($fptr-ref-bits type (ftd-bits-eness ftd) signed? fptr offset start end))) '(_ _))) field)) @@ -876,7 +954,7 @@ ftype operators: [(ftd-base? ftd) (guard (c [#t 'invalid]) ($fptr-ref (filter-foreign-type (ftd-base-type ftd)) - (ftd-base-swap? ftd) fptr offset))] + (ftd-base-eness ftd) fptr offset))] [else ($oops '$fptr->sexpr "unhandled ftd ~s" ftd)]))))))) (set! $unwrap-ftype-pointer (lambda (fptr) @@ -917,9 +995,9 @@ ftype operators: (lambda (id signed? start end) `(,id ,(lambda () (guard (c [#t 'invalid]) - ($fptr-ref-bits type (ftd-bits-swap? ftd) signed? fptr 0 start end))) + ($fptr-ref-bits type (ftd-bits-eness ftd) signed? fptr 0 start end))) ,(lambda (v) - (#2%$fptr-set-bits! type (ftd-bits-swap? ftd) fptr 0 + (#2%$fptr-set-bits! type (ftd-bits-eness ftd) fptr 0 start end v)))) field)) (ftd-bits-field* ftd))))] @@ -927,8 +1005,8 @@ ftype operators: (let ([type (filter-foreign-type (ftd-base-type ftd))]) `(base ,type - ,(lambda () (guard (c [#t 'invalid]) ($fptr-ref type (ftd-base-swap? ftd) fptr 0))) - ,(lambda (v) (#2%$fptr-set! (ftd-base-type ftd) type (ftd-base-swap? ftd) fptr 0 v))))] + ,(lambda () (guard (c [#t 'invalid]) ($fptr-ref type (ftd-base-eness ftd) fptr 0))) + ,(lambda (v) (#2%$fptr-set! (ftd-base-type ftd) type (ftd-base-eness ftd) fptr 0 v))))] [else ($oops '$unwrap-ftype-pointer "unhandled ftd ~s" ftd)])))) (set! $trans-ftype-sizeof (lambda (x) @@ -1077,9 +1155,11 @@ ftype operators: (define trans-bitfield (lambda (ftd signed? offset start end do-base do-bits) (define (little-endian?) - (constant-case native-endianness - [(little) (not (ftd-bits-swap? ftd))] - [(big) (ftd-bits-swap? ftd)])) + (or (eq? (ftd-bits-eness ftd) 'little) + (and (eq? (constant native-endianness) 'little) + (eq? (ftd-bits-eness ftd) 'native)) + (and (eq? (constant native-endianness) 'big) + (eq? (ftd-bits-eness ftd) 'swapped)))) (let ([width (fx- end start)]) (cond [(and (fx= width 8) (fx= (mod start 8) 0)) @@ -1089,19 +1169,19 @@ ftype operators: (div start 8) (fx- (ftd-size ftd) (div start 8) 1))))] [(and (fx= width 16) (fx= (mod start 16) 0)) - (do-base (if signed? 'integer-16 'unsigned-16) (ftd-bits-swap? ftd) + (do-base (if signed? 'integer-16 'unsigned-16) (ftd-bits-eness ftd) #`(fx+ #,offset #,(if (little-endian?) (div start 8) (fx- (ftd-size ftd) (div start 8) 2))))] [(and (fx= width 32) (fx= (mod start 32) 0)) - (do-base (if signed? 'integer-32 'unsigned-32) (ftd-bits-swap? ftd) + (do-base (if signed? 'integer-32 'unsigned-32) (ftd-bits-eness ftd) #`(fx+ #,offset #,(if (little-endian?) (div start 8) (fx- (ftd-size ftd) (div start 8) 4))))] [(and (fx= width 64) (fx= start 0)) - (do-base (if signed? 'integer-64 'unsigned-64) (ftd-bits-swap? ftd) offset)] + (do-base (if signed? 'integer-64 'unsigned-64) (ftd-bits-eness ftd) offset)] [else (or (and (and (fx= (ftd-size ftd) 8) (fx= (constant ptr-bits) 32)) (cond @@ -1173,12 +1253,19 @@ ftype operators: #`(let ([offset #,(trans-idx ?idx ?idx ftd (make-index-info #'ftype-ref ?idx ftd #t))]) #,(let-values ([(fptr-expr offset ftd idx* bitfield) (ftype-access-code #'ftype-ref ftd a* fptr-expr #'offset)]) - (define (do-base type swap? offset) - (with-syntax ([$fptr-ref-x (datum->syntax #'kwd - (string->symbol - (format "$fptr-ref-~:[~;swap-~]~a" - swap? type)))]) - #`(#3%$fptr-ref-x #,fptr-expr #,offset))) + (define (do-base type eness offset) + (let ([eness (simplify-eness eness type)]) + (case eness + [(native swapped) + (with-syntax ([$fptr-ref-x (datum->syntax #'kwd + (string->symbol + (format "$fptr-ref-~:[~;swap-~]~a" + (eq? eness 'swapped) type)))]) + #`(#3%$fptr-ref-x #,fptr-expr #,offset))] + [else + (with-syntax ([type (datum->syntax #'kwd type)] + [eness (datum->syntax #'kwd eness)]) + #`(#3%$fptr-ref 'type 'eness #,fptr-expr #,offset))]))) (with-syntax ([((containing-ftd a-id a len) ...) idx*]) (with-syntax ([(info ...) (map (lambda (a containing-ftd) (make-index-info 'ftype-ref a containing-ftd #f)) #'(a ...) #'(containing-ftd ...))]) #`(let ([a-id a] ...) @@ -1192,15 +1279,22 @@ ftype operators: (lambda (id signed? start end) (trans-bitfield ftd signed? offset start end do-base (lambda (size offset start end) - (with-syntax ([$fptr-ref-bits-x (datum->syntax #'* - (string->symbol - (format "$fptr-ref-~:[u~;i~]bits-~:[~;swap-~]~a" - signed? - (ftd-bits-swap? ftd) - (unsigned-type size))))]) - #`(#3%$fptr-ref-bits-x #,fptr-expr #,offset #,start #,end))))) + (let ([eness (simplify-eness (ftd-bits-eness ftd) (unsigned-type size))]) + (case eness + [(native swapped) + (with-syntax ([$fptr-ref-bits-x (datum->syntax #'* + (string->symbol + (format "$fptr-ref-~:[u~;i~]bits-~:[~;swap-~]~a" + signed? + (eq? eness 'swapped) + (unsigned-type size))))]) + #`(#3%$fptr-ref-bits-x #,fptr-expr #,offset #,start #,end))] + [else + (with-syntax ([type (datum->syntax #'kwd (unsigned-type size))] + [eness (datum->syntax #'* eness)]) + #`(#3%$fptr-ref-bits 'type 'eness '#,signed? #,fptr-expr #,offset #,start #,end))]))))) bitfield)] - [(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-swap? ftd) offset)] + [(ftd-base? ftd) (do-base (filter-foreign-type (ftd-base-type ftd)) (ftd-base-eness ftd) offset)] [(ftd-pointer? ftd) #`(#3%$fptr-fptr-ref #,fptr-expr #,offset '#,(ftd-pointer-ftd ftd))] [(ftd-function? ftd) ($make-foreign-procedure 'make-ftype-pointer @@ -1232,12 +1326,19 @@ ftype operators: #,(let-values ([(fptr-expr offset ftd idx* bitfield) (ftype-access-code #'ftype-set! ftd a* fptr-expr #'offset)]) (define (do-base orig-type) - (lambda (type swap? offset) - (with-syntax ([$fptr-set-x! (datum->syntax #'kwd - (string->symbol - (format "$fptr-set-~:[~;swap-~]~a!" - swap? type)))]) - #`($fptr-set-x! '#,(make-field-info orig-type val-expr) #,fptr-expr #,offset val)))) + (lambda (type eness offset) + (let ([eness (simplify-eness eness type)]) + (case eness + [(native swapped) + (with-syntax ([$fptr-set-x! (datum->syntax #'kwd + (string->symbol + (format "$fptr-set-~:[~;swap-~]~a!" + (eq? eness 'swapped) type)))]) + #`($fptr-set-x! '#,(make-field-info orig-type val-expr) #,fptr-expr #,offset val))] + [else + (with-syntax ([type (datum->syntax #'kwd type)] + [eness (datum->syntax #'kwd eness)]) + #`($fptr-set! '#,(make-field-info orig-type val-expr) 'type 'eness #,fptr-expr #,offset val))])))) (with-syntax ([((containing-ftd a-id a len) ...) idx*]) (with-syntax ([(info ...) (map (lambda (a containing-ftd) (make-index-info 'ftype-set! a containing-ftd #f)) #'(a ...) #'(containing-ftd ...))]) #`(let ([a-id a] ...) @@ -1251,16 +1352,23 @@ ftype operators: (lambda (id signed? start end) (trans-bitfield ftd signed? offset start end (do-base 'bit-field) (lambda (size offset start end) - (with-syntax ([$fptr-set-bits-x! (datum->syntax #'* - (string->symbol - (format "$fptr-set-bits-~:[~;swap-~]~a!" - (ftd-bits-swap? ftd) - (unsigned-type size))))]) - #`($fptr-set-bits-x! #,fptr-expr #,offset #,start #,end val))))) + (let ([eness (simplify-eness (ftd-bits-eness ftd) (unsigned-type size))]) + (case eness + [(native swapped) + (with-syntax ([$fptr-set-bits-x! (datum->syntax #'* + (string->symbol + (format "$fptr-set-bits-~:[~;swap-~]~a!" + (eq? eness 'swapped) + (unsigned-type size))))]) + #`($fptr-set-bits-x! #,fptr-expr #,offset #,start #,end val))] + [else + (with-syntax ([type (datum->syntax #'kwd (unsigned-type size))] + [eness (datum->syntax #'* eness)]) + #`($fptr-set-bits! 'type 'eness #,fptr-expr #,offset #,start #,end val))]))))) bitfield)] [(ftd-base? ftd) (let ([orig-type (ftd-base-type ftd)]) - ((do-base orig-type) (filter-foreign-type orig-type) (ftd-base-swap? ftd) offset))] + ((do-base orig-type) (filter-foreign-type orig-type) (ftd-base-eness ftd) offset))] [(ftd-pointer? ftd) #`(begin (unless #,(fx= (optimize-level) 3) @@ -1303,8 +1411,8 @@ ftype operators: [(64) '(unsigned-64 integer-64)] [(32) '(unsigned-32 integer-32)])) (syntax-error q "locked operation on non-integer or non-word-size field unsupported")) - (when (ftd-base-swap? ftd) - (syntax-error q "locked operation on swapped field unsupported")) + (unless (eq? (ftd-base-eness ftd) 'native) + (syntax-error q "locked operation on non-native field unsupported")) #`(($primitive 3 #,prim) #,fptr-expr #,offset))] [else (syntax-error q "locked operation on non-base-type field unsupported")]))))))))))) (syntax-case q () @@ -1329,7 +1437,7 @@ ftype operators: (constant-case ptr-bits [(64) '(unsigned-64 integer-64)] [(32) '(unsigned-32 integer-32)])) - (not (ftd-base-swap? ftd))))] + (eq? 'native (ftd-base-eness ftd))))] [(ftd-struct? ftd) (let ([ls (ftd-struct-field* ftd)]) (if (null? ls) @@ -1377,16 +1485,20 @@ ftype operators: (set! $fptr-ref-integer-24 (lambda (fptr offset) - (#3%$fptr-ref-integer-24 fptr offset))) + (multi-int foreign-ref integer-24 + (#3%$fptr-ref-integer-24 fptr offset)))) (set! $fptr-ref-unsigned-24 (lambda (fptr offset) - (#3%$fptr-ref-unsigned-24 fptr offset))) + (multi-int foreign-ref unsigned-24 + (#3%$fptr-ref-unsigned-24 fptr offset)))) (set! $fptr-ref-swap-integer-24 (lambda (fptr offset) - (#3%$fptr-ref-swap-integer-24 fptr offset))) + (multi-int $foreign-swap-ref integer-24 + (#3%$fptr-ref-swap-integer-24 fptr offset)))) (set! $fptr-ref-swap-unsigned-24 (lambda (fptr offset) - (#3%$fptr-ref-swap-unsigned-24 fptr offset))) + (multi-int $foreign-swap-ref unsigned-24 + (#3%$fptr-ref-swap-unsigned-24 fptr offset)))) (set! $fptr-ref-integer-32 (lambda (fptr offset) @@ -1403,42 +1515,54 @@ ftype operators: (set! $fptr-ref-integer-40 (lambda (fptr offset) - (#3%$fptr-ref-integer-40 fptr offset))) + (multi-int foreign-ref integer-40 + (#3%$fptr-ref-integer-40 fptr offset)))) (set! $fptr-ref-unsigned-40 (lambda (fptr offset) - (#3%$fptr-ref-unsigned-40 fptr offset))) + (multi-int foreign-ref unsigned-40 + (#3%$fptr-ref-unsigned-40 fptr offset)))) (set! $fptr-ref-swap-integer-40 (lambda (fptr offset) - (#3%$fptr-ref-swap-integer-40 fptr offset))) + (multi-int $foreign-swap-ref integer-40 + (#3%$fptr-ref-swap-integer-40 fptr offset)))) (set! $fptr-ref-swap-unsigned-40 (lambda (fptr offset) - (#3%$fptr-ref-swap-unsigned-40 fptr offset))) + (multi-int $foreign-swap-ref unsigned-40 + (#3%$fptr-ref-swap-unsigned-40 fptr offset)))) (set! $fptr-ref-integer-48 (lambda (fptr offset) - (#3%$fptr-ref-integer-48 fptr offset))) + (multi-int foreign-ref integer-48 + (#3%$fptr-ref-integer-48 fptr offset)))) (set! $fptr-ref-unsigned-48 (lambda (fptr offset) - (#3%$fptr-ref-unsigned-48 fptr offset))) + (multi-int foreign-ref unsigned-48 + (#3%$fptr-ref-unsigned-48 fptr offset)))) (set! $fptr-ref-swap-integer-48 (lambda (fptr offset) - (#3%$fptr-ref-swap-integer-48 fptr offset))) + (multi-int $foreign-swap-ref integer-48 + (#3%$fptr-ref-swap-integer-48 fptr offset)))) (set! $fptr-ref-swap-unsigned-48 (lambda (fptr offset) - (#3%$fptr-ref-swap-unsigned-48 fptr offset))) + (multi-int $foreign-swap-ref unsigned-48 + (#3%$fptr-ref-swap-unsigned-48 fptr offset)))) (set! $fptr-ref-integer-56 (lambda (fptr offset) - (#3%$fptr-ref-integer-56 fptr offset))) + (multi-int foreign-ref integer-56 + (#3%$fptr-ref-integer-56 fptr offset)))) (set! $fptr-ref-unsigned-56 (lambda (fptr offset) - (#3%$fptr-ref-unsigned-56 fptr offset))) + (multi-int foreign-ref unsigned-56 + (#3%$fptr-ref-unsigned-56 fptr offset)))) (set! $fptr-ref-swap-integer-56 (lambda (fptr offset) - (#3%$fptr-ref-swap-integer-56 fptr offset))) + (multi-int $foreign-swap-ref integer-56 + (#3%$fptr-ref-swap-integer-56 fptr offset)))) (set! $fptr-ref-swap-unsigned-56 (lambda (fptr offset) - (#3%$fptr-ref-swap-unsigned-56 fptr offset))) + (multi-int $foreign-swap-ref unsigned-56 + (#3%$fptr-ref-swap-unsigned-56 fptr offset)))) (set! $fptr-ref-integer-64 (lambda (fptr offset) @@ -1463,7 +1587,7 @@ ftype operators: [(32) (let ([bv (make-bytevector 8)]) (bytevector-u64-set! bv 0 (foreign-ref 'unsigned-64 ($ftype-pointer-address fptr) offset) - (if (eq? (constant native-endianness) 'big) 'little 'big)) + (swapped-endianness)) ($object-ref 'double-float bv (constant bytevector-data-disp)))]))) (set! $fptr-ref-single-float @@ -1476,7 +1600,7 @@ ftype operators: [(32) (let ([bv (make-bytevector 4)]) (bytevector-u32-set! bv 0 (foreign-ref 'unsigned-32 ($ftype-pointer-address fptr) offset) - (if (eq? (constant native-endianness) 'big) 'little 'big)) + (swapped-endianness)) ($object-ref 'single-float bv (constant bytevector-data-disp)))]))) (set! $fptr-ref-char @@ -1505,7 +1629,7 @@ ftype operators: (#3%$fptr-ref-swap-fixnum fptr offset))) (set-who! $fptr-ref - (lambda (ty swap? fptr offset) + (lambda (ty eness fptr offset) (define-syntax proc (lambda (x) (syntax-case x (scheme-object) @@ -1515,7 +1639,8 @@ ftype operators: (datum->syntax #'* (string->symbol (format "$fptr-ref-~a" (datum type)))) - #`(if swap? + #`(if (or (eq? eness 'swapped) + (eq? eness (swapped-endianness))) #,(datum->syntax #'* (string->symbol (format "$fptr-ref-swap-~a" (datum type)))) @@ -1564,19 +1689,23 @@ ftype operators: (set! $fptr-set-integer-24! (lambda (info fptr offset val) (unless ($integer-24? val) (invalid-value info val)) - (#3%$fptr-set-integer-24! info fptr offset val))) + (multi-int foreign-set! integer-24 + (#3%$fptr-set-integer-24! info fptr offset val)))) (set! $fptr-set-unsigned-24! (lambda (info fptr offset val) (unless ($integer-24? val) (invalid-value info val)) - (#3%$fptr-set-unsigned-24! info fptr offset val))) + (multi-int foreign-set! unsigned-24 + (#3%$fptr-set-unsigned-24! info fptr offset val)))) (set! $fptr-set-swap-integer-24! (lambda (info fptr offset val) (unless ($integer-24? val) (invalid-value info val)) - (#3%$fptr-set-swap-integer-24! info fptr offset val))) + (multi-int $foreign-swap-set! integer-24 + (#3%$fptr-set-swap-integer-24! info fptr offset val)))) (set! $fptr-set-swap-unsigned-24! (lambda (info fptr offset val) (unless ($integer-24? val) (invalid-value info val)) - (#3%$fptr-set-swap-unsigned-24! info fptr offset val))) + (multi-int $foreign-swap-set! unsigned-24 + (#3%$fptr-set-swap-unsigned-24! info fptr offset val)))) (set! $fptr-set-integer-32! (lambda (info fptr offset val) @@ -1598,134 +1727,86 @@ ftype operators: (set! $fptr-set-integer-40! (lambda (info fptr offset val) (unless ($integer-40? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-integer-40! info fptr offset val)] - [(32) (foreign-set! 'integer-40 ($ftype-pointer-address fptr) offset val)]))) + (multi-int/wide foreign-set! integer-40 + (#3%$fptr-set-integer-40! info fptr offset val)))) (set! $fptr-set-unsigned-40! (lambda (info fptr offset val) (unless ($integer-40? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-unsigned-40! info fptr offset val)] - [(32) (foreign-set! 'unsigned-40 ($ftype-pointer-address fptr) offset val)]))) + (multi-int/wide foreign-set! unsigned-40 + (#3%$fptr-set-unsigned-40! info fptr offset val)))) (set! $fptr-set-swap-integer-40! (lambda (info fptr offset val) (unless ($integer-40? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-integer-40! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'integer-40 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-40 ($ftype-pointer-address fptr) offset - (bytevector-u40-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (multi-int/wide $foreign-swap-set! integer-40 + (#3%$fptr-set-swap-integer-40! info fptr offset val)))) (set! $fptr-set-swap-unsigned-40! (lambda (info fptr offset val) (unless ($integer-40? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-unsigned-40! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'unsigned-40 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-40 ($ftype-pointer-address fptr) offset - (bytevector-u40-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (multi-int/wide $foreign-swap-set! unsigned-40 + (#3%$fptr-set-swap-unsigned-40! info fptr offset val)))) (set! $fptr-set-integer-48! (lambda (info fptr offset val) (unless ($integer-48? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-integer-48! info fptr offset val)] - [(32) (foreign-set! 'integer-48 ($ftype-pointer-address fptr) offset val)]))) + (multi-int/wide foreign-set! integer-48 + (#3%$fptr-set-integer-48! info fptr offset val)))) (set! $fptr-set-unsigned-48! (lambda (info fptr offset val) (unless ($integer-48? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-unsigned-48! info fptr offset val)] - [(32) (foreign-set! 'unsigned-48 ($ftype-pointer-address fptr) offset val)]))) + (multi-int/wide foreign-set! unsigned-48 + (#3%$fptr-set-unsigned-48! info fptr offset val)))) (set! $fptr-set-swap-integer-48! (lambda (info fptr offset val) (unless ($integer-48? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-integer-48! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'integer-48 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-48 ($ftype-pointer-address fptr) offset - (bytevector-u48-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (multi-int/wide $foreign-swap-set! integer-48 + (#3%$fptr-set-swap-integer-48! info fptr offset val)))) (set! $fptr-set-swap-unsigned-48! (lambda (info fptr offset val) (unless ($integer-48? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-unsigned-48! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'unsigned-48 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-48 ($ftype-pointer-address fptr) offset - (bytevector-u48-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) - + (multi-int/wide $foreign-swap-set! unsigned-48 + (#3%$fptr-set-swap-unsigned-48! info fptr offset val)))) + (set! $fptr-set-integer-56! (lambda (info fptr offset val) (unless ($integer-56? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-integer-56! info fptr offset val)] - [(32) (foreign-set! 'integer-56 ($ftype-pointer-address fptr) offset val)]))) + (multi-int/wide foreign-set! integer-56 + (#3%$fptr-set-integer-56! info fptr offset val)))) (set! $fptr-set-unsigned-56! (lambda (info fptr offset val) (unless ($integer-56? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-unsigned-56! info fptr offset val)] - [(32) (foreign-set! 'unsigned-56 ($ftype-pointer-address fptr) offset val)]))) + (multi-int/wide foreign-set! unsigned-56 + (#3%$fptr-set-unsigned-56! info fptr offset val)))) (set! $fptr-set-swap-integer-56! (lambda (info fptr offset val) (unless ($integer-56? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-integer-56! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'integer-56 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-56 ($ftype-pointer-address fptr) offset - (bytevector-u56-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (multi-int/wide $foreign-swap-set! integer-56 + (#3%$fptr-set-swap-integer-56! info fptr offset val)))) (set! $fptr-set-swap-unsigned-56! (lambda (info fptr offset val) (unless ($integer-56? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-unsigned-56! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'unsigned-56 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-56 ($ftype-pointer-address fptr) offset - (bytevector-u56-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (multi-int/wide $foreign-swap-set! unsigned-56 + (#3%$fptr-set-swap-unsigned-56! info fptr offset val)))) (set! $fptr-set-integer-64! (lambda (info fptr offset val) (unless ($integer-64? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-integer-64! info fptr offset val)] - [(32) (foreign-set! 'integer-64 ($ftype-pointer-address fptr) offset val)]))) + (wide foreign-set! integer-64 + (#3%$fptr-set-integer-64! info fptr offset val)))) (set! $fptr-set-unsigned-64! (lambda (info fptr offset val) (unless ($integer-64? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-unsigned-64! info fptr offset val)] - [(32) (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset val)]))) + (wide foreign-set! unsigned-64 + (#3%$fptr-set-unsigned-64! info fptr offset val)))) (set! $fptr-set-swap-integer-64! (lambda (info fptr offset val) (unless ($integer-64? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-integer-64! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'integer-64 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset - (bytevector-u64-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (wide $foreign-swap-set! integer-64 + (#3%$fptr-set-swap-integer-64! info fptr offset val)))) (set! $fptr-set-swap-unsigned-64! (lambda (info fptr offset val) (unless ($integer-64? val) (invalid-value info val)) - (constant-case ptr-bits - [(64) (#3%$fptr-set-swap-unsigned-64! info fptr offset val)] - [(32) (let ([bv (make-bytevector 8)]) - ($object-set! 'unsigned-64 bv (constant bytevector-data-disp) val) - (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset - (bytevector-u64-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (wide $foreign-swap-set! unsigned-64 + (#3%$fptr-set-swap-unsigned-64! info fptr offset val)))) (set! $fptr-set-double-float! (lambda (info fptr offset val) @@ -1740,7 +1821,7 @@ ftype operators: ($object-set! 'double-float bv (constant bytevector-data-disp) val) (foreign-set! 'unsigned-64 ($ftype-pointer-address fptr) offset (bytevector-u64-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big))))]))) + (swapped-endianness))))]))) (set! $fptr-set-single-float! (lambda (info fptr offset val) @@ -1753,7 +1834,7 @@ ftype operators: ($object-set! 'single-float bv (constant bytevector-data-disp) val) (foreign-set! 'unsigned-32 ($ftype-pointer-address fptr) offset (bytevector-u32-ref bv 0 - (if (eq? (constant native-endianness) 'big) 'little 'big)))))) + (swapped-endianness)))))) (set! $fptr-set-char! (lambda (info fptr offset val) @@ -1787,7 +1868,7 @@ ftype operators: ) (set-who! $fptr-set! - (lambda (orig-type ty swap? fptr offset val) + (lambda (orig-type ty eness fptr offset val) (define-syntax proc (lambda (x) (syntax-case x (scheme-object) @@ -1798,7 +1879,8 @@ ftype operators: #,(datum->syntax #'* (string->symbol (format "$fptr-set-~a!" (datum type))))) - #`(if swap? + #`(if (or (eq? eness 'swapped) + (eq? eness (swapped-endianness))) ($primitive 2 #,(datum->syntax #'* (string->symbol @@ -1892,7 +1974,7 @@ ftype operators: (set! $fptr-ref-ubits-unsigned-64 ($fptr-ref-ubits 64 #f))) (set-who! $fptr-ref-bits - (lambda (ty swap? signed? fptr offset start end) + (lambda (ty eness signed? fptr offset start end) (define-syntax proc (lambda (x) (syntax-case x () @@ -1905,7 +1987,8 @@ ftype operators: #,(datum->syntax #'* (string->symbol (format "$fptr-ref-ubits-~a" (datum type))))) - #`(if swap? + #`(if (or (eq? eness 'swapped) + (eq? eness (swapped-endianness))) (if signed? #,(datum->syntax #'* (string->symbol @@ -1923,7 +2006,11 @@ ftype operators: ((case ty [(unsigned-8) (proc unsigned-8)] [(unsigned-16) (proc unsigned-16)] + [(unsigned-24) (proc unsigned-24)] [(unsigned-32) (proc unsigned-32)] + [(unsigned-40) (proc unsigned-40)] + [(unsigned-48) (proc unsigned-48)] + [(unsigned-56) (proc unsigned-56)] [(unsigned-64) (proc unsigned-64)] [else ($oops who "unexpected type ~s" ty)]) fptr offset start end))) @@ -1992,7 +2079,7 @@ ftype operators: (set! $fptr-set-bits-unsigned-64! ($fptr-set-bits! 64 #f))) (set-who! $fptr-set-bits! - (lambda (ty swap? fptr offset start end val) + (lambda (ty eness fptr offset start end val) (define-syntax proc (lambda (x) (syntax-case x () @@ -2001,7 +2088,8 @@ ftype operators: (datum->syntax #'* (string->symbol (format "$fptr-set-bits-~a!" (datum type)))) - #`(if swap? + #`(if (or (eq? eness 'swapped) + (eq? eness (swapped-endianness))) ($primitive 2 #,(datum->syntax #'* (string->symbol @@ -2013,7 +2101,11 @@ ftype operators: ((case ty [(unsigned-8) (proc unsigned-8)] [(unsigned-16) (proc unsigned-16)] + [(unsigned-24) (proc unsigned-24)] [(unsigned-32) (proc unsigned-32)] + [(unsigned-40) (proc unsigned-40)] + [(unsigned-48) (proc unsigned-48)] + [(unsigned-56) (proc unsigned-56)] [(unsigned-64) (proc unsigned-64)] [else ($oops who "unexpected type ~s" ty)]) fptr offset start end val))) diff --git a/s/inspect.ss b/s/inspect.ss index 7f28535e66..031c9ee5ef 100644 --- a/s/inspect.ss +++ b/s/inspect.ss @@ -2582,12 +2582,11 @@ (lambda (x) (cond [(pair? x) - (let ([space ($seginfo-space ($maybe-seginfo x))]) - (cond - [(eqv? space (constant space-ephemeron)) - (fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))] - [else - (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))]))] + (cond + [(ephemeron-pair? x) + (fx+ (constant size-ephemeron) (compute-size (car x)) (compute-size (cdr x)))] + [else + (fx+ (constant size-pair) (compute-size (car x)) (compute-size (cdr x)))])] [(symbol? x) (fx+ (constant size-symbol) (compute-size (#3%$top-level-value x)) diff --git a/s/io.ss b/s/io.ss index 541a7f39a5..9b7eb11ebf 100644 --- a/s/io.ss +++ b/s/io.ss @@ -262,15 +262,11 @@ implementation notes: (string boolean) scheme-object)) (define $open-output-fd (foreign-procedure "(cs)new_open_output_fd" - (string int - boolean boolean boolean - boolean boolean boolean boolean) + (string int int) scheme-object)) (define $open-input/output-fd (foreign-procedure "(cs)new_open_input_output_fd" - (string int - boolean boolean boolean - boolean boolean boolean boolean) + (string int int) scheme-object)) (define $close-fd (foreign-procedure "(cs)close_fd" @@ -2478,7 +2474,8 @@ implementation notes: (define UTF-32B/LE (constant-case native-endianness [(little) "UTF-32LE"] - [(big) "UTF-32BE"])) + [(big) "UTF-32BE"] + [(unknown) "UTF-32"])) (define (iconv-open to from) (let ([desc ($iconv-open to from)]) (when (string? desc) ($oops who "~a" desc)) @@ -4092,9 +4089,14 @@ implementation notes: (when (file-exists? filename) (collect (collect-maximum-generation)))))) (let ([fd (critical-section - ($open-output-fd filename perms - no-create no-fail no-truncate - append lock replace compressed))]) + ($open-output-fd filename perms + (fxior (if no-create (constant open-fd-no-create) 0) + (if no-fail (constant open-fd-no-fail) 0) + (if no-truncate (constant open-fd-no-truncate) 0) + (if append (constant open-fd-append) 0) + (if lock (constant open-fd-lock) 0) + (if replace (constant open-fd-replace) 0) + (if compressed (constant open-fd-compressed) 0))))]) (when (pair? fd) (open-oops who filename options fd)) (open-binary-fd-output-port who filename fd #t b-mode lock compressed))))) @@ -5074,8 +5076,13 @@ implementation notes: (collect (collect-maximum-generation)))))) (let ([fd (critical-section ($open-input/output-fd filename perms - no-create no-fail no-truncate - append lock replace compressed))]) + (fxior (if no-create (constant open-fd-no-create) 0) + (if no-fail (constant open-fd-no-fail) 0) + (if no-truncate (constant open-fd-no-truncate) 0) + (if append (constant open-fd-append) 0) + (if lock (constant open-fd-lock) 0) + (if replace (constant open-fd-replace) 0) + (if compressed (constant open-fd-compressed) 0))))]) (when (pair? fd) (open-oops who filename options fd)) (open-binary-fd-input/output-port who filename fd #t b-mode lock compressed))))) diff --git a/s/mkgc.ss b/s/mkgc.ss index 107b5a2a4b..513ceb5469 100644 --- a/s/mkgc.ss +++ b/s/mkgc.ss @@ -166,8 +166,8 @@ (copy pair-cdr) (case-mode [(copy) - (set! (ephemeron-prev-ref _copy_) NULL) - (set! (ephemeron-next _copy_) NULL)] + (set! (ephemeron-prev-ref _copy_) 0) + (set! (ephemeron-next _copy_) 0)] [else]) (add-ephemeron-to-pending) (mark one-bit no-sweep) @@ -349,7 +349,7 @@ (and-counts (== p_spc space-count-impure))))) (let* ([ua_size : uptr (unaligned_size_record_inst len)]) (when (!= p_sz ua_size) - (set! (* (cast ptr* (+ (cast uptr (UNTYPE _copy_ type_typed_object)) ua_size))) + (set! (* (cast ptr* (TO_VOIDP (+ (cast uptr (UNTYPE _copy_ type_typed_object)) ua_size)))) (FIX 0)))))) (count-record rtd)] @@ -753,7 +753,7 @@ [(case-flag as-dirty? [on 0] [off (== mask (>> (cast uptr -1) 1))]) - (let* ([ppend : ptr* (- (cast ptr* (+ (cast uptr pp) len)) 1)]) + (let* ([ppend : ptr* (- (cast ptr* (TO_VOIDP (+ (cast uptr (TO_PTR pp)) len))) 1)]) (while :? (< pp ppend) (trace (* pp)) @@ -808,7 +808,7 @@ ;; Don't need to save fields of base-rtd (when (== _ (-> vfi base_rtd)) (let* ([pp : ptr* (& (record-data _ 0))] - [ppend : ptr* (- (cast ptr* (+ (cast uptr pp) (UNFIX (record-type-size rtd)))) 1)]) + [ppend : ptr* (- (cast ptr* (TO_VOIDP (+ (cast uptr (TO_PTR pp)) (UNFIX (record-type-size rtd))))) 1)]) (while :? (< pp ppend) (set! (* pp) Snil) @@ -974,7 +974,7 @@ (when (< fp base) (S_error_abort "sweep_stack(gc): malformed stack")) (set! fp (- fp (ENTRYFRAMESIZE ret))) - (let* ([pp : ptr* (cast ptr* fp)] + (let* ([pp : ptr* (cast ptr* (TO_VOIDP fp))] [oldret : iptr ret]) (set! ret (cast iptr (* pp))) (trace-return NO-COPY-MODE (* pp)) @@ -1014,7 +1014,7 @@ (trace-return-code field xcp)])) (define-trace-macro (trace-return-code field xcp) - (define co : iptr (+ (ENTRYOFFSET xcp) (- (cast uptr xcp) (cast uptr (ENTRYOFFSETADDR xcp))))) + (define co : iptr (+ (ENTRYOFFSET xcp) (- (cast uptr xcp) (cast uptr (TO_PTR (ENTRYOFFSETADDR xcp)))))) (define c_p : ptr (cast ptr (- (cast uptr xcp) co))) (case-mode [sweep @@ -1046,7 +1046,7 @@ [vfasl-sweep (let* ([r_sz : uptr (size_reloc_table m)] [new_t : ptr (vfasl_find_room vfi vspace_reloc typemod r_sz)]) - (memcpy_aligned new_t t r_sz) + (memcpy_aligned (TO_VOIDP new_t) (TO_VOIDP t) r_sz) (set! t new_t))] [else]) (define a : iptr 0) @@ -1099,10 +1099,10 @@ [else (let* ([oldt : ptr t]) (find_room space_data target_generation typemod n t) - (memcpy_aligned t oldt n))]))) + (memcpy_aligned (TO_VOIDP t) (TO_VOIDP oldt) n))]))) (set! (reloc-table-code t) _) (set! (code-reloc _) t)]) - (S_record_code_mod tc_in (cast uptr (& (code-data _ 0))) (cast uptr (code-length _)))] + (S_record_code_mod tc_in (cast uptr (TO_PTR (& (code-data _ 0)))) (cast uptr (code-length _)))] [vfasl-sweep ;; no vfasl_register_pointer, since relink_code can handle it (set! (reloc-table-code t) (cast ptr (ptr_diff _ (-> vfi base_addr)))) @@ -1160,8 +1160,8 @@ (define-trace-macro (vfasl-pad-word) (case-mode [(vfasl-copy) - (set! (array-ref (cast void** (UNTYPE _copy_ type_typed_object)) 3) - (cast ptr 0))] + (set! (array-ref (cast ptr* (TO_VOIDP (UNTYPE _copy_ type_typed_object))) 3) + 0)] [else])) (define-trace-macro (vfasl-fail what) @@ -1564,7 +1564,7 @@ (case (lookup 'mode config) [(copy) (code (code-block - (format "ptr tmp_p = TYPE(&~a, type_flonum);" (field-expression field config "p" #t)) + (format "ptr tmp_p = TYPE(TO_PTR(&~a), type_flonum);" (field-expression field config "p" #t)) "if (flonum_is_forwarded_p(tmp_p, si))" (format " ~a = FLODAT(FLONUM_FWDADDRESS(tmp_p));" (field-expression field config "new_p" #f)) @@ -2239,7 +2239,7 @@ (define (ensure-segment-mark-mask si inset flags) (code (format "~aif (!~a->marked_mask) {" inset si) - (format "~a find_room(space_data, target_generation, typemod, ptr_align(segment_bitmap_bytes), ~a->marked_mask);" + (format "~a find_room_voidp(space_data, target_generation, ptr_align(segment_bitmap_bytes), ~a->marked_mask);" inset si) (if (memq 'no-clear flags) (format "~a /* no clearing needed */" inset) diff --git a/s/mkheader.ss b/s/mkheader.ss index 4d4b216057..b7e3fb58b5 100644 --- a/s/mkheader.ss +++ b/s/mkheader.ss @@ -65,7 +65,7 @@ (pr "EXPORT ~a ~a PROTO(~a);~%" tresult name targs))) (define &ref (lambda (cast x disp) - (format "(~a((uptr)(~a)~:[+~;-~]~d))" cast x (fx< disp 0) (abs disp)))) + (format "(~aTO_VOIDP((uptr)(~a)~:[+~;-~]~d))" cast x (fx< disp 0) (abs disp)))) (define ref (lambda (cast x disp) (format "(*~a)" (&ref cast x disp)))) @@ -187,6 +187,13 @@ (nl) (comment "Warning: Some macros may evaluate arguments more than once.") + (constant-case architecture + [(pb) + (nl) + (pr "#define _LARGEFILE64_SOURCE\n") ; needed on some 32-bit platforms before + (pr "#include \n")] + [else (void)]) + (nl) (comment "Enable function prototypes by default.") (pr "#ifndef PROTO~%#define PROTO(x) x~%#endif~%") @@ -228,6 +235,21 @@ (pr "typedef ~a ptr;~%" (constant typedef-ptr)) (pr "typedef ~a iptr;~%" (constant typedef-iptr)) (pr "typedef ~a uptr;~%" (constant typedef-uptr)) + (pr "typedef ptr xptr;~%") + + (nl) + (comment "The `uptr` and `ptr` types are the same width, but `ptr`") + (comment "can be either an integer type or a pointer type; it may") + (comment "be larger than a pointer type.") + (comment "Use `TO_VOIDP` to get from the `uptr`/`ptr` world to the") + (comment "C pointer worlds, and use `TO_PTR` to go the other way.") + (pr "#ifdef PORTABLE_BYTECODE~%") + (pr "# define TO_VOIDP(p) ((void *)(intptr_t)(p))~%") + (pr "# define TO_PTR(p) ((ptr)(intptr_t)(p))~%") + (pr "#else~%") + (pr "# define TO_VOIDP(p) ((void *)(p))~%") + (pr "# define TO_PTR(p) ((ptr)(p))~%") + (pr "#endif~%") (nl) (comment "String elements are 32-bit tagged char objects") @@ -422,6 +444,41 @@ (lambda (x) (pr "#define FEATURE_~@:(~a~)~%" (sanitize x))) (feature-list)) + (constant-case architecture + [(pb) + (nl) (comment "C call prototypes.") + (pr "#include \n") + (for-each + (lambda (proto+id) + (let ([proto (car proto+id)]) + (define (sym->type s) + (case s + [(int8) 'int8_t] + [(int16) 'int16_t] + [(int32) 'int32_t] + [(uint32) 'uint32_t] + [(int64) 'int64_t] + [(uint64) 'uint64_t] + [else s])) + (define (clean-type s) + (case s + [(void*) 'voids] + [else s])) + (pr "typedef ~a (*pb_~a_t)(~a);~%" + (sym->type (car proto)) + (apply string-append + (symbol->string (clean-type (car proto))) + (map (lambda (s) (format "_~a" (clean-type s))) + (cdr proto))) + (if (null? (cdr proto)) + "" + (apply string-append + (symbol->string (sym->type (cadr proto))) + (map (lambda (s) (format ", ~a" (sym->type s))) + (cddr proto))))))) + (reverse (constant pb-prototype-table)))] + [else (void)]) + (nl) (comment "Locking macros.") (constant-case architecture [(x86) @@ -775,6 +832,12 @@ (pr " : \"=&r\" (ret)\\~%") (pr " : \"r\" (addr)\\~%") (pr " : \"cc\", \"memory\", \"x12\", \"x7\")~%")] + [(pb) + (pr "#define INITLOCK(addr) (*((long *) addr) = 0)~%") + (pr "#define SPINLOCK(addr) (*((long *) addr) = 1)~%") + (pr "#define UNLOCK(addr) (*((long *) addr) = 0)~%") + (pr "#define LOCKED_INCR(addr, res) (res = ((*(uptr*)addr)-- == 1))~%") + (pr "#define LOCKED_DECR(addr, res) (res = ((*(uptr*)addr)-- == 1))~%")] [else ($oops who "asm locking code is not yet defined for ~s" (constant architecture))])))) diff --git a/s/np-languages.ss b/s/np-languages.ss index 169371e7d0..9c1e4d21a7 100644 --- a/s/np-languages.ss +++ b/s/np-languages.ss @@ -616,6 +616,7 @@ (declare-primitive sll value #t) (declare-primitive srl value #t) (declare-primitive sra value #t) + (declare-primitive slol value #t) ; runtime-detemined endianness only: shift toward lo byte (declare-primitive zext8 value #t) (declare-primitive zext16 value #t) (declare-primitive zext32 value #t) ; 64-bit only diff --git a/s/pb.def b/s/pb.def new file mode 100644 index 0000000000..13ade827ec --- /dev/null +++ b/s/pb.def @@ -0,0 +1,39 @@ +;;; pb.def + +(define-constant machine-type (constant machine-type-pb)) +(define-constant architecture 'pb) +(define-constant address-bits 64) +(define-constant ptr-bits 64) +(define-constant int-bits 32) +(define-constant short-bits 16) +(define-constant long-bits 64) +(define-constant long-long-bits 64) +(define-constant size_t-bits 64) +(define-constant ptrdiff_t-bits 64) +(define-constant wchar-bits 32) +(define-constant time-t-bits 64) +(define-constant max-float-alignment 8) +(define-constant max-integer-alignment 8) +(define-constant asm-arg-reg-max 7) +(define-constant asm-arg-reg-cnt 3) +(define-constant asm-fpreg-max 8) +(define-constant typedef-ptr "uint64_t") ; not "void *" +(define-constant typedef-iptr "int64_t") +(define-constant typedef-uptr "uint64_t") +(define-constant typedef-i8 "int8_t") +(define-constant typedef-u8 "uint8_t") +(define-constant typedef-i16 "int16_t") +(define-constant typedef-u16 "uint16_t") +(define-constant typedef-i32 "int32_t") +(define-constant typedef-u32 "uint32_t") +(define-constant typedef-i64 "int64_t") +(define-constant typedef-u64 "uint64_t") +(define-constant typedef-string-char "uint32_t") +(define-constant native-endianness 'unknown) +(define-constant unaligned-floats #f) +(define-constant unaligned-integers #f) +(define-constant integer-divide-instruction #t) +(define-constant popcount-instruction #f) +(define-constant software-floating-point #f) +(define-constant segment-table-levels 3) +(features) diff --git a/s/pb.ss b/s/pb.ss new file mode 100644 index 0000000000..ce6dcb4ecd --- /dev/null +++ b/s/pb.ss @@ -0,0 +1,1612 @@ +;;; pb.ss + +;; The pb (portable bytecode) interpreter is implemented by "pb.c". +;; The intent is that the machine uses 64-bit Scheme object +;; representations and a runtime-determined endianness, so code +;; compiled as portable bytecode can run on any machine (as long as +;; the C compiler supports 64-bit integers for the kernel's +;; implementation, where care is taken for the conversion between C +;; pointers and Scheme object addresses). That way, a single set of pb +;; boot files can be used to bootstrap the compiler for any supporrted +;; platform. + +;; The pb machine can be configured (through ".def") for 32-bit Scheme +;; object representations and a specific endianness, but that's not +;; the main intended use. + +;; In all configurations, the pb machine uses 32-bit instructions. The +;; fasl format of instructuctions is always little-endian, and the +;; machine-code content is swapped on load for a big-endian +;; environment. + +;; The pb binstruction set is load--store and vaguely similar to Arm. +;; One difference is that there's a single flag for branching: +;; signalling arithemtic, bitwise, and comparison operations set the +;; flag for a specific condition, such as "overflow" or "equal", and +;; the branch variants are "branch if true" or "branch if false". + +;; Each 32-bit instruction has one of these formats, shown in byte +;; order for a little-endian machine: +;; +;; low byte high byte +;; 8 8 8 8 +;; ----------------------------------------------- +;; | op | reg | immed/reg | +;; ----------------------------------------------- +;; ----------------------------------------------- +;; | op | reg reg | immed/reg | +;; ----------------------------------------------- +;; ----------------------------------------------- +;; | op | immed | +;; ----------------------------------------------- +;; +;; Integer and floating-point registers (up to 16 of each) are +;; different, and an `op` determines which bank is meant for a `reg` +;; reference. The low-bits `reg` in the byte after the `op` tends to +;; be the destination register. The long `immed` form is mainly for +;; branches. See "cmacros.ss" for the `op` constructions. + +;; Foreign-procedure calls are supported only for specific prototypes, +;; which are generally the ones for functions implemented the Chez +;; Scheme kernel. Supported prototypes are specified in "cmacros.ss". +;; Foreign callables are not supported. All foreign-call arguments and +;; results are passed in registers. + +;;; SECTION 1: registers + +(define-registers + (reserved + [%tc #t 0 uptr] + [%sfp #t 1 uptr] + [%ap #t 2 uptr] + [%trap #t 3 uptr]) + (allocable + [%ac0 #f 4 uptr] + [%xp #f 5 uptr] + [%ts #f 6 uptr] + [%td #f 7 uptr] + [%cp #f 8 uptr] + [%r9 %Carg1 %Cretval #f 9 uptr] + [%r10 %Carg2 #f 10 uptr] + [%r11 %Carg3 #f 11 uptr] + [%r12 %Carg4 #f 12 uptr] + [%r13 %Carg5 #f 13 uptr] + [%r14 %Carg6 #f 14 uptr] + [%r15 %Carg7 #f 15 uptr] + [%fp1 #f 0 fp] + [%fp2 %Cfparg1 %Cfpretval #f 1 fp] + [%fp3 %Cfparg2 #f 2 fp] + [%fp4 %Cfparg3 #f 3 fp] + [%fp5 %Cfparg4 #f 4 fp] + [%fp6 %Cfparg5 #f 5 fp] + [%fp7 %Cfparg6 #f 6 fp] + [%fp8 #f 7 fp]) + (machine-dependent)) + +;;; SECTION 2: instructions +(module (md-handle-jump ; also sets primitive handlers + mem->mem + fpmem->fpmem + coercible? + coerce-opnd) + (import asm-module) + + (define imm-signed16? + (lambda (x) + (nanopass-case (L15c Triv) x + [(immediate ,imm) (signed16? imm)] + [else #f]))) + + (define mref->mref + (lambda (a k) + (define return + (lambda (x0 x1 imm type) + ;; load & store instructions support index or offset, but not both + (safe-assert (or (eq? x1 %zero) (eqv? imm 0))) + (k (with-output-language (L15d Triv) `(mref ,x0 ,x1 ,imm ,type))))) + (nanopass-case (L15c Triv) a + [(mref ,lvalue0 ,lvalue1 ,imm ,type) + (lvalue->ur lvalue0 + (lambda (x0) + (lvalue->ur lvalue1 + (lambda (x1) + (cond + [(and (eq? x1 %zero) (signed16? imm)) + (return x0 %zero imm type)] + [(and (not (eq? x1 %zero)) (signed16? imm)) + (if (eqv? imm 0) + (return x0 x1 0 type) + (let ([u (make-tmp 'u)]) + (seq + (build-set! ,u (asm ,null-info ,(asm-add #f) ,x1 (immediate ,imm))) + (return x0 u 0 type))))] + [else + (let ([u (make-tmp 'u)]) + (seq + (build-set! ,u (immediate ,imm)) + (if (eq? x1 %zero) + (return x0 u 0 type) + (seq + (build-set! ,u (asm ,null-info ,(asm-add #f) ,u ,x1)) + (return x0 u 0 type)))))])))))]))) + + (define mem->mem + (lambda (a k) + (cond + [(literal@? a) + (let ([u (make-tmp 'u)]) + (seq + (build-set! ,u ,(literal@->literal a)) + (k (with-output-language (L15d Lvalue) `(mref ,u ,%zero 0 uptr)))))] + [else (mref->mref a k)]))) + + (define fpmem->fpmem mem->mem) + + ;; `define-instruction` code takes care of `ur` and `fpur`, to which + ;; all type-compatible values must convert + (define-syntax coercible? + (syntax-rules () + [(_ ?a ?aty*) + (let ([a ?a] [aty* ?aty*]) + (or (and (memq 'signed16 aty*) (imm-signed16? a)) + (and (memq 'mem aty*) (mem? a)) + (and (memq 'fpmem aty*) (fpmem? a))))])) + + ;; `define-instruction` doesn't try to cover `ur` and `fpur` + (define-syntax coerce-opnd ; passes k something compatible with aty* + (syntax-rules () + [(_ ?a ?aty* ?k) + (let ([a ?a] [aty* ?aty*] [k ?k]) + (cond + [(and (memq 'mem aty*) (mem? a)) (mem->mem a k)] + [(and (memq 'fpmem aty*) (fpmem? a)) (fpmem->fpmem a k)] + [(and (memq 'signed16 aty*) (imm-signed16? a)) (k (imm->imm a))] + [(or (memq 'ur aty*) + (memq 'fpur aty*)) + (cond + [(ur? a) (k a)] + [(imm? a) + (let ([u (make-tmp 'u)]) + (seq + (build-set! ,u ,(imm->imm a)) + (k u)))] + [(or (mem? a) (fpmem? a)) + (let ([type (if (fpmem? a) 'fp 'uptr)]) + (mem->mem a + (lambda (a) + (let ([u (make-tmp 'u type)]) + (seq + (build-set! ,u ,a) + (k u))))))] + [else (sorry! 'coerce-opnd "unexpected operand ~s" a)])] + [else (sorry! 'coerce-opnd "cannot coerce ~s to ~s" a aty*)]))])) + + (define md-handle-jump + (lambda (t) + (with-output-language (L15d Tail) + (define long-form + (lambda (e) + (let ([tmp (make-tmp 'utmp)]) + (values + (in-context Effect `(set! ,(make-live-info) ,tmp ,e)) + `(jump ,tmp))))) + (nanopass-case (L15c Triv) t + [,lvalue + (if (mem? lvalue) + (mem->mem lvalue (lambda (e) (values '() `(jump ,e)))) + (values '() `(jump ,lvalue)))] + [(literal ,info) + (guard (and (not (info-literal-indirect? info)) + (memq (info-literal-type info) '(entry library-code)))) + (values '() `(jump (literal ,info)))] + [(label-ref ,l ,offset) + (values '() `(jump (label-ref ,l ,offset)))] + [else (long-form t)])))) + + (define info-cc-eq (make-info-condition-code 'eq? #f #t)) + (define asm-eq (asm-relop info-cc-eq)) + + ; x is not the same as z in any clause that follows a clause where (x z) + ; and y is coercible to one of its types, however: + ; WARNING: do not assume that if x isn't the same as z then x is independent + ; of z, since x might be an mref with z as it's base or index + + (define-instruction value (- -/ovfl -/eq) + [(op (z ur) (x ur) (y signed16)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub op) ,x ,y))] + [(op (z ur) (x ur) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-sub op) ,x ,y))]) + + (define-instruction value (+ +/ovfl +/carry) + [(op (z ur) (x ur) (y signed16)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))] + [(op (z ur) (x signed16) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,y ,x))] + [(op (z ur) (x ur) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add (memq op '(+/ovfl +/carry))) ,x ,y))]) + + (define-instruction value (* */ovfl) + [(op (z ur) (x ur) (y signed16)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-mul (memq op '(*/ovfl))) ,x ,y))] + [(op (z ur) (x signed16) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-mul (memq op '(*/ovfl))) ,y ,x))] + [(op (z ur) (x ur) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-mul (memq op '(*/ovfl))) ,x ,y))]) + + (define-instruction value (/) + [(op (z ur) (x ur) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,asm-div ,x ,y))]) + + (define-instruction value (logand logor logxor) + [(op (z ur) (x ur) (y signed16)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,x ,y))] + [(op (z ur) (x signed16) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,y ,x))] + [(op (z ur) (x ur) (y ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,x ,y))]) + + (define-instruction value (lognot) + [(op (z ur) (x ur)) + `(set! ,(make-live-info) ,z (asm ,info ,asm-lognot ,x))]) + + (define-instruction value (sll srl sra slol) + [(op (z ur) (x ur) (y signed16 ur)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-logical op) ,x ,y))]) + + (define-instruction value (move) + [(op (z mem) (x ur)) + `(set! ,(make-live-info) ,z ,x)] + [(op (z ur) (x ur mem signed16)) + `(set! ,(make-live-info) ,z ,x)]) + + (let () + (define build-lea1 + (lambda (info z x) + (let ([offset (info-lea-offset info)]) + (with-output-language (L15d Effect) + (cond + [(signed16? offset) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x (immediate ,offset)))] + [else + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (immediate ,offset)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,x ,u))))]))))) + + (define-instruction value lea1 + [(op (z ur) (x ur)) (build-lea1 info z x)]) + + (define-instruction value lea2 + [(op (z ur) (x ur) (y ur)) + (let ([u (make-tmp 'u)]) + (seq + (build-lea1 info u x) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-add #f) ,y ,u))))])) + + (let () + (define imm-zero (with-output-language (L15d Triv) `(immediate 0))) + (define load/store + (lambda (x y w k) ; x ur, y ur, w ur or imm + (with-output-language (L15d Effect) + (if (ur? w) + (if (eq? y %zero) + (k x w) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,y ,w)) + (k x u)))) + (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) + (cond + [(and (eq? y %zero) (signed16? n)) + (let ([w (in-context Triv `(immediate ,n))]) + (k x w))] + [(eqv? n 0) + (k x y)] + [(signed16? n) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x (immediate ,n))) + (k u y)))] + [else + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (immediate ,n)) + (if (eq? y %zero) + (k x u) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,u)) + (k u y)))))])))))) + (define-instruction value (load) + [(op (z ur) (x ur) (y ur) (w ur signed16)) + (let ([type (info-load-type info)]) + (load/store x y w + (lambda (x y) + (let ([instr `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-load type) ,x ,y))]) + (if (info-load-swapped? info) + (seq + instr + `(set! ,(make-live-info) ,z (asm ,null-info ,(asm-swap type) ,z))) + instr)))))]) + (define-instruction effect (store) + [(op (x ur) (y ur) (w ur signed16) (z ur)) + (let ([type (info-load-type info)]) + (load/store x y w + (lambda (x y) + (if (info-load-swapped? info) + (let ([u (make-tmp 'unique-bob)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-swap type) ,z)) + `(asm ,null-info ,(asm-store type) ,x ,y ,u))) + `(asm ,null-info ,(asm-store type) ,x ,y ,z)))))])) + + (define-instruction value (load-single->double) + [(op (x fpur) (y fpmem)) `(set! ,(make-live-info) ,x (asm ,null-info ,asm-fpmove-single ,y))]) + + (define-instruction effect (store-double->single) + [(op (x fpmem) (y fpur)) `(asm ,info ,asm-fpmove-single ,x ,y)]) + + (define-instruction value (single->double double->single) + [(op (x fpur) (y fpur)) + `(set! ,(make-live-info) ,x (asm ,info ,(asm-fl-cvt op) ,y))]) + + (define-instruction value (fpt) + [(op (x fpur) (y ur)) + `(set! ,(make-live-info) ,x (asm ,info ,asm-fpt ,y))]) + + (define-instruction value (fptrunc) + [(op (x ur) (y fpur)) + `(set! ,(make-live-info) ,x (asm ,info ,asm-fptrunc ,y))]) + + (define-instruction value (fpmove) + [(op (x fpmem) (y fpur)) `(set! ,(make-live-info) ,x ,y)] + [(op (x fpur) (y fpmem fpur)) `(set! ,(make-live-info) ,x ,y)]) + + (constant-case ptr-bits + [(64) + (let () + (define (mem->mem mem new-type) + (nanopass-case (L15d Triv) mem + [(mref ,x0 ,x1 ,imm ,type) + (with-output-language (L15d Lvalue) `(mref ,x0 ,x1 ,imm ,new-type))])) + + (define-instruction value (fpcastto) + [(op (x mem) (y fpur)) `(set! ,(make-live-info) ,(mem->mem x 'fp) ,y)] + [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastto ,y))]) + + (define-instruction value (fpcastfrom) + [(op (x fpmem) (y ur)) `(set! ,(make-live-info) ,(mem->mem x 'uptr) ,y)] + [(op (x fpur) (y ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,y))]))] + [(32) + (let () + (define (mem->mem mem delta) + (nanopass-case (L15d Triv) mem + [(mref ,x0 ,x1 ,imm ,type) + (let ([delta (constant-case native-endianness + [(little) (if (eq? delta 'lo) 0 4)] + [(big) (if (eq? delta 'hi) 0 4)])]) + (with-output-language (L15d Lvalue) `(mref ,x0 ,x1 ,(fx+ imm delta) uptr)))])) + + (define-instruction value (fpcastto/hi) + [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(mem->mem y 'hi))] + [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'hi) ,y))]) + + (define-instruction value (fpcastto/lo) + [(op (x ur) (y fpmem)) `(set! ,(make-live-info) ,x ,(mem->mem y 'lo))] + [(op (x ur) (y fpur)) `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpcastto 'lo) ,y))]) + + (define-instruction value (fpcastfrom) + [(op (x fpmem) (hi ur) (lo ur)) (seq + `(set! ,(make-live-info) ,(mem->mem x 'lo) ,lo) + `(set! ,(make-live-info) ,(mem->mem x 'hi) ,hi))] + [(op (x fpur) (hi ur) (lo ur)) `(set! ,(make-live-info) ,x (asm ,info ,asm-fpcastfrom ,lo ,hi))]))]) + + (define-instruction value (fp+ fp- fp/ fp*) + [(op (x fpur) (y fpur) (z fpur)) + `(set! ,(make-live-info) ,x (asm ,info ,(asm-fpop-2 op) ,y ,z))]) + + (define-instruction value (fpsqrt) + [(op (x fpur) (y fpur)) + `(set! ,(make-live-info) ,x (asm ,info ,asm-fpsqrt ,y))]) + + (define-instruction pred (fp= fp< fp<=) + [(op (x fpur) (y fpur)) + (let ([info (make-info-condition-code op #f #f)]) + (values '() `(asm ,info ,(asm-fp-relop info) ,x ,y)))]) + + (define-instruction effect (inc-cc-counter) + [(op (x ur) (w signed16) (z ur signed16)) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,w)) + `(asm ,info ,asm-inc! ,u ,z)))]) + + (define-instruction effect (inc-profile-counter) + [(op (x mem) (y signed16)) + (nanopass-case (L15d Triv) x + [(mref ,x0 ,x1 ,imm ,type) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x0 ,(if (eq? x1 %zero) + `(immediate ,imm) + x1))) + `(asm ,info ,asm-inc! ,u ,y)))])]) + + (define-instruction value (read-time-stamp-counter) + [(op (z ur)) `(set! ,(make-live-info) ,z (immediate 0))]) + + (define-instruction value (read-performance-monitoring-counter) + [(op (z ur) (x ur)) `(set! ,(make-live-info) ,z (immediate 0))]) + + (define-instruction value (asmlibcall) + [(op (z ur)) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) + `(set! ,(make-live-info) ,z (asm ,info ,(asm-library-call (info-asmlib-libspec info)) ,u ,(info-kill*-live*-live* info) ...))))]) + + (define-instruction effect (asmlibcall!) + [(op) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) + `(asm ,info ,(asm-library-call! (info-asmlib-libspec info)) ,u ,(info-kill*-live*-live* info) ...)))]) + + (define-instruction effect (c-simple-call) + [(op) + (let ([u (make-tmp 'u)]) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,asm-kill)) + `(asm ,info ,(asm-c-simple-call (info-c-simple-call-entry info)) ,u)))]) + + (define-instruction pred (eq? u< < > <= >= logtest log!test) + [(op (y signed16) (x ur)) + (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #t #t))]) + (values '() `(asm ,info ,(asm-relop info) ,x ,y)))] + [(op (x ur) (y ur signed16)) + (let ([info (if (eq? op 'eq?) info-cc-eq (make-info-condition-code op #f #t))]) + (values '() `(asm ,info ,(asm-relop info) ,x ,y)))]) + + (define-instruction pred (condition-code) + [(op) (values '() `(asm ,info ,(asm-condition-code info)))]) + + (define-instruction pred (type-check?) + [(op (x ur) (mask signed16 ur) (type signed16 ur)) + (let ([tmp (make-tmp 'u)]) + (values + (with-output-language (L15d Effect) + `(set! ,(make-live-info) ,tmp (asm ,null-info ,(asm-logical 'logand) ,x ,mask))) + `(asm ,info-cc-eq ,asm-eq ,tmp ,type)))]) + + (let () + (define (addr-reg x y w k) + (with-output-language (L15d Effect) + (let ([n (nanopass-case (L15d Triv) w [(immediate ,imm) imm])]) + (cond + [(and (eq? y %zero) (fx= n 0)) + (k x)] + [else + (let ([u (make-tmp 'u)]) + (cond + [(eq? y %zero) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,w)) + (k u))] + [(fx= n 0) + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y)) + (k u))] + [else + (seq + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,x ,y)) + `(set! ,(make-live-info) ,u (asm ,null-info ,(asm-add #f) ,u ,w)) + (k u))]))])))) + + (define-instruction pred (lock!) + [(op (x ur) (y ur) (w signed16)) + (addr-reg x y w (lambda (u) + (values '() `(asm ,info-cc-eq ,(asm-lock! info-cc-eq) ,u))))]) + + (define-instruction effect (locked-incr!) + [(op (x ur) (y ur) (w signed16)) + (addr-reg x y w (lambda (u) + ;; signals on zero after increment + `(asm ,info ,asm-inc! ,u (immediate 1))))]) + (define-instruction effect (locked-decr!) + [(op (x ur) (y ur) (w signed16)) + (addr-reg x y w (lambda (u) + ;; signals on zero after decrement + `(asm ,info ,asm-inc! ,u (immediate -1))))]) + + (define-instruction effect (cas) + [(op (x ur) (y ur) (w signed16) (old ur) (new ur)) + (addr-reg x y w (lambda (u) + ;; signals on successful swap + `(asm ,info ,asm-cas! ,u ,old ,new)))])) + + (define-instruction effect (pause) + ;; NB: use sqrt or something like that? + [(op) '()]) + + (define-instruction effect (c-call) + [(op (x ur) (y signed16)) `(asm ,info ,asm-indirect-call ,x ,y ,(info-kill*-live*-live* info) ...)]) + + (define-instruction effect save-flrv + [(op) '()]) + + (define-instruction effect restore-flrv + [(op) '()]) + + (define-instruction effect (invoke-prelude) + [(op) '()]) +) + +;;; SECTION 3: assembler +(module asm-module (; required exports + asm-move asm-load asm-store asm-swap asm-library-call asm-library-call! asm-library-jump + asm-mul asm-div asm-add asm-sub asm-logical asm-lognot + asm-fp-relop asm-relop + asm-indirect-jump asm-literal-jump + asm-direct-jump asm-return-address asm-jump asm-conditional-jump + asm-indirect-call asm-condition-code + asm-fpmove-single asm-fl-cvt asm-fpt asm-fpmove asm-fpcastto asm-fpcastfrom asm-fptrunc + asm-inc! asm-lock! asm-cas! + asm-fpop-2 asm-fpsqrt asm-c-simple-call + asm-return asm-c-return asm-size + asm-enter asm-foreign-call asm-foreign-callable + asm-kill + signed16?) + + (define ax-register? + (case-lambda + [(x) (record-case x [(reg) r #t] [else #f])] + [(x reg) (record-case x [(reg) r (eq? r reg)] [else #f])])) + + (define-who ax-ea-reg-code + (lambda (ea) + (record-case ea + [(reg) r (reg-mdinfo r)] + [else (sorry! who "ea=~s" ea)]))) + + (define ax-reg? + (lambda (ea) + (record-case ea + [(reg) ignore #t] + [else #f]))) + + (define ax-imm? + (lambda (ea) + (record-case ea + [(imm) ignore #t] + [else #f]))) + + (define-who ax-imm-data + (lambda (ea) + (record-case ea + [(imm) (n) n] + [else (sorry! who "ax-imm-data ea=~s" ea)]))) + + ; define-op sets up assembly op macros-- + ; the opcode and all other expressions are passed to the specified handler-- + (define-syntax define-op + (lambda (x) + (syntax-case x () + [(k op handler e ...) + (with-syntax ([op (construct-name #'k "asmop-" #'op)]) + #'(define-syntax op + (syntax-rules () + [(_ mneu arg (... ...)) + (handler 'mneu e ... arg (... ...))])))]))) + + (define-syntax emit + (lambda (x) + (syntax-case x () + [(k op x ...) + (with-syntax ([emit-op (construct-name #'k "asmop-" #'op)]) + #'(emit-op op x ...))]))) + + (define-op mov mov-op (constant pb-i->i)) + (define-op fpmov mov-op (constant pb-d->d)) + + (define-op movzi movi-op #f) ; 16-bit immediate, shifted + (define-op movki movi-op #t) ; 16-bit immediate, shifted + + (define-op add signal-bin-op (constant pb-add)) + (define-op sub signal-bin-op (constant pb-sub)) + (define-op mul signal-bin-op (constant pb-mul)) + (define-op div bin-op (constant pb-div)) + + (define-op subz signal-bin-op (constant pb-subz)) ; signals on 0 instead of overflow + + (define-op land bin-op (constant pb-and)) + (define-op lior bin-op (constant pb-ior)) + (define-op lxor bin-op (constant pb-xor)) + (define-op lnot un-op (constant pb-not)) + + (define-op lsl bin-op (constant pb-lsl)) + (define-op lsr bin-op (constant pb-lsr)) + (define-op asr bin-op (constant pb-asr)) + (define-op lslo bin-op (constant pb-lslo)) + + (define-op rev rev-op) + + (define-op eq cmp-op (constant pb-eq)) + (define-op lt cmp-op (constant pb-lt)) + (define-op gt cmp-op (constant pb-gt)) + (define-op le cmp-op (constant pb-le)) + (define-op ge cmp-op (constant pb-ge)) + (define-op ab cmp-op (constant pb-ab)) ; above: unsigned compare + (define-op bl cmp-op (constant pb-bl)) ; below: unsigned compare + (define-op cs cmp-op (constant pb-cs)) ; bits in common + (define-op cc cmp-op (constant pb-cc)) ; no bits in common + + (define-op ld load-op) + (define-op st store-op) + + (define-op fadd fp-bin-op (constant pb-add)) + (define-op fsub fp-bin-op (constant pb-sub)) + (define-op fmul fp-bin-op (constant pb-mul)) + (define-op fdiv fp-bin-op (constant pb-div)) + + (define-op fpeq fp-cmp-op (constant pb-eq)) + (define-op fplt fp-cmp-op (constant pb-lt)) + (define-op fple fp-cmp-op (constant pb-le)) + + (define-op fsqrt fp-un-op (constant pb-sqrt)) + + (define-op mov.s->d mov-op (constant pb-s->d)) + (define-op mov.d->s mov-op (constant pb-d->s)) + (define-op mov.i->d mov-op (constant pb-i->d)) + (define-op mov.d->i mov-op (constant pb-d->i)) + + ;; 64-bit versions + (define-op mov.i*>d mov-op (constant pb-i-bits->d-bits)) + (define-op mov.d*>i mov-op (constant pb-d-bits->i-bits)) + + ;; 32-bit versions + (define-op mov.ii*>d mov2-op (constant pb-i-i-bits->d-bits)) + (define-op mov.d*l>i mov-op (constant pb-d-lo-bits->i-bits)) + (define-op mov.d*h>i mov-op (constant pb-d-hi-bits->i-bits)) + + (define-op btrue branch-op (constant pb-true)) + (define-op bfals branch-op (constant pb-fals)) + (define-op b branch-op (constant pb-always)) + (define-op b* branch-indirect-op) + + (define-op lock lock-op) + (define-op cas cas-op) + (define-op inc inc-op) + + (define-op call call-op) + (define-op interp interp-op) + (define-op ret ret-op) + (define-op adr adr-op) ; use only for an address after an rpheader (or compact) + + (define movi-op + (lambda (op keep? dest imm shift code*) + (emit-code (op dest imm shift code*) + (fx+ (constant pb-mov16) + (if keep? + (constant pb-keep-bits) + (constant pb-zero-bits)) + shift) + (ax-ea-reg-code dest) + imm))) + + (define mov-op + (lambda (op mode dest src code*) + (emit-code (op dest src code*) + (fx+ (constant pb-mov) + mode) + (ax-ea-reg-code dest) + (ax-ea-reg-code src)))) + + (define mov2-op + (lambda (op mode dest src0 src1 code*) + (emit-code (op dest src0 src1 code*) + (fx+ (constant pb-mov) + mode) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1)))) + + (define signal-bin-op + (lambda (op opcode set-cc? dest src0 src1 code*) + (cond + [(ax-reg? src1) + (emit-code (op set-cc? dest src0 src1 code*) + (fx+ (constant pb-bin-op) + (if set-cc? + (constant pb-signal) + (constant pb-no-signal)) + opcode + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1))] + [else + (emit-code (op set-cc? dest src0 src1 code*) + (fx+ (constant pb-bin-op) + (if set-cc? + (constant pb-signal) + (constant pb-no-signal)) + opcode + (constant pb-immediate)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-imm-data src1))]))) + + (define bin-op + (lambda (op opcode dest src0 src1 code*) + (cond + [(ax-reg? src1) + (emit-code (op dest src0 src1 code*) + (fx+ (constant pb-bin-op) + (constant pb-no-signal) + opcode + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1))] + [else + (emit-code (op dest src0 src1 code*) + (fx+ (constant pb-bin-op) + (constant pb-no-signal) + opcode + (constant pb-immediate)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-imm-data src1))]))) + + (define un-op + (lambda (op opcode dest src code*) + (cond + [(ax-reg? src) + (emit-code (op dest src code*) + (fx+ (constant pb-un-op) + opcode + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src))] + [else + (emit-code (op dest src code*) + (fx+ (constant pb-un-op) + opcode + (constant pb-immediate)) + (ax-ea-reg-code dest) + (ax-imm-data src))]))) + + (define rev-op + (lambda (op size dest src code*) + (emit-code (op dest src code*) + (fx+ (constant pb-rev-op) + size + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src)))) + + (define cmp-op + (lambda (op opcode src0 src1 code*) + (cond + [(ax-reg? src1) + (emit-code (op src0 src1 code*) + (fx+ (constant pb-cmp-op) + opcode + (constant pb-register)) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1))] + [else + (emit-code (op src0 src1 code*) + (fx+ (constant pb-cmp-op) + opcode + (constant pb-immediate)) + (ax-ea-reg-code src0) + (ax-imm-data src1))]))) + + (define load-op + (lambda (op size dest src0 src1 code*) + (cond + [(ax-reg? src1) + (emit-code (op size dest src0 src1 code*) + (fx+ (constant pb-ld-op) + size + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1))] + [else + (emit-code (op size dest src0 src1 code*) + (fx+ (constant pb-ld-op) + size + (constant pb-immediate)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-imm-data src1))]))) + + (define store-op + (lambda (op size dest0 dest1 src code*) + (cond + [(ax-reg? dest1) + (emit-code (op size dest0 dest1 src code*) + (fx+ (constant pb-st-op) + size + (constant pb-register)) + (ax-ea-reg-code src) + (ax-ea-reg-code dest0) + (ax-ea-reg-code dest1))] + [else + (emit-code (op size dest0 dest1 src code*) + (fx+ (constant pb-st-op) + size + (constant pb-immediate)) + (ax-ea-reg-code src) + (ax-ea-reg-code dest0) + (ax-imm-data dest1))]))) + + (define fp-bin-op + (lambda (op opcode dest src0 src1 code*) + (emit-code (op dest src0 src1 code*) + (fx+ (constant pb-fp-bin-op) + opcode + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1)))) + + (define fp-un-op + (lambda (op opcode dest src code*) + (emit-code (op dest src code*) + (fx+ (constant pb-fp-un-op) + opcode + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src)))) + + (define fp-cmp-op + (lambda (op opcode src0 src1 code*) + (emit-code (op src0 src1 code*) + (fx+ (constant pb-fp-cmp-op) + opcode + (constant pb-register)) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1)))) + + (define-who branch-op + (lambda (op sel addr code*) + (record-case addr + [(reg) r + (emit-code (op sel addr code*) + (fx+ (constant pb-b-op) + sel + (constant pb-register)) + 0 + (reg-mdinfo r))] + [(imm) (n) + (emit-code (op sel addr code*) + (fx+ (constant pb-b-op) + sel + (constant pb-immediate)) + n)] + [(label) (offset l) + (emit-code (op sel addr code*) + (fx+ (constant pb-b-op) + sel + (constant pb-immediate)) + offset)] + [else + (sorry! who "unrecognized destination ~s" addr)]))) + + (define branch-indirect-op + (lambda (op src0 src1 code*) + (cond + [(ax-reg? src1) + (emit-code (op src0 src1 code*) + (fx+ (constant pb-b*-op) + (constant pb-register)) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1))] + [else + (emit-code (op src0 src1 code*) + (fx+ (constant pb-b*-op) + (constant pb-immediate)) + (ax-ea-reg-code src0) + (ax-imm-data src1))]))) + + (define ret-op + (lambda (op code*) + (emit-code (op code*) + (constant pb-return) + 0 + 0))) + + (define call-op + (lambda (op dest proto code*) + (emit-code (op dest code*) + (constant pb-call) + (ax-ea-reg-code dest) + (ax-imm-data proto)))) + + (define interp-op + (lambda (op dest code*) + (emit-code (op dest code*) + (constant pb-interp) + (ax-ea-reg-code dest) + 0))) + + (define adr-op + (lambda (op dest offset code*) + (emit-code (op dest offset code*) + (constant pb-adr) + (ax-ea-reg-code dest) + offset))) + + (define inc-op + (lambda (op dest src code*) + (cond + [(ax-reg? src) + (emit-code (op dest src code*) + (fx+ (constant pb-inc) + (constant pb-register)) + (ax-ea-reg-code dest) + (ax-ea-reg-code src))] + [else + (emit-code (op dest src code*) + (fx+ (constant pb-inc) + (constant pb-immediate)) + (ax-ea-reg-code dest) + (ax-imm-data src))]))) + + (define lock-op + (lambda (op dest code*) + (emit-code (op dest code*) + (constant pb-lock) + (ax-ea-reg-code dest) + 0))) + + (define cas-op + (lambda (op dest src0 src1 code*) + (emit-code (op dest src0 src1 code*) + (constant pb-cas) + (ax-ea-reg-code dest) + (ax-ea-reg-code src0) + (ax-ea-reg-code src1)))) + + (define-syntax emit-code + (lambda (x) + (syntax-case x () + [(_ (op opnd ... ?code*) chunk ...) + (let ([safe-check (lambda (e) + (if (fx= (debug-level) 0) + e + #`(let ([code #,e]) + (unless (<= 0 code (sub1 (expt 2 32))) + (sorry! 'emit-code "bad result ~s for ~s" + code + (list op opnd ...))) + code)))]) + #`(cons (build long #,(safe-check #`(byte-fields chunk ...))) + (aop-cons* `(asm ,op ,opnd ...) ?code*)))]))) + + (define-syntax build + (syntax-rules () + [(_ x e) + (and (memq (datum x) '(byte word long)) (integer? (datum e))) + (begin + (safe-assert (fixnum? (datum e))) + (quote (x . e)))] + [(_ x e) + (memq (datum x) '(byte word long)) + (cons 'x e)])) + + (define-syntax byte-fields + (syntax-rules () + [(byte-fields op d r/i) + (+ op + (bitwise-arithmetic-shift-left d 8) + (bitwise-arithmetic-shift-left (fxand r/i #xFFFF) 16))] + [(byte-fields op d r r/i) + (+ op + (bitwise-arithmetic-shift-left d 8) + (bitwise-arithmetic-shift-left r 12) + (bitwise-arithmetic-shift-left (fxand r/i #xFFFF) 16))] + [(byte-fields op i) + (+ op + (bitwise-arithmetic-shift-left (fxand i #xFFFFFF) 8))])) + + (define signed16? + (lambda (imm) + (and (fixnum? imm) (fx<= (fx- (expt 2 15)) imm (fx- (expt 2 15) 1))))) + + (define signed24? + (lambda (imm) + (and (fixnum? imm) (fx<= (fx- (expt 2 23)) imm (fx- (expt 2 23) 1))))) + + (define asm-size + (lambda (x) + (case (car x) + [(asm pb-abs pb-proc) 0] + [(long) 4] + [else (constant-case ptr-bits + [(64) 8] + [(32) 4])]))) + + (define ax-mov64 + (lambda (dest n code*) + (emit movzi dest (logand n #xffff) 0 + (emit movki dest (logand (bitwise-arithmetic-shift-right n 16) #xffff) 1 + (emit movki dest (logand (bitwise-arithmetic-shift-right n 32) #xffff) 2 + (emit movki dest (logand (bitwise-arithmetic-shift-right n 48) #xffff) 3 + code*)))))) + + (define ax-movi + (lambda (dest n code*) + (let loop ([n n] [shift 0] [init? #t]) + (cond + [(or (eqv? n 0) (fx= shift 4)) + (if init? + ;; make sure 0 is installed + (emit movzi dest 0 0 code*) + code*)] + [else + (let ([m (logand n #xFFFF)]) + (cond + [(eqv? m 0) + (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) init?)] + [else + (let ([code* (loop (bitwise-arithmetic-shift-right n 16) (fx+ shift 1) #f)]) + (if init? + (emit movzi dest m shift code*) + (emit movki dest m shift code*)))]))])))) + + (define-who asm-move + (lambda (code* dest src) + ;; move pseudo instruction used by set! case in select-instruction + ;; guarantees dest is a reg and src is reg, mem, or imm OR dest is + ;; mem and src is reg. + (Trivit (dest src) + (define (bad!) (sorry! who "unexpected combination of src ~s and dest ~s" src dest)) + (cond + [(ax-reg? dest) + (record-case src + [(reg) ignore (emit mov dest src code*)] + [(imm) (n) + (ax-movi dest n code*)] + [(literal) stuff + (ax-mov64 dest 0 + (asm-helper-relocation code* (cons 'pb-abs stuff)))] + [(disp) (n breg) + (safe-assert (signed16? n)) + (emit ld (constant pb-int64) dest `(reg . ,breg) `(imm ,n) code*)] + [(index) (n ireg breg) + (safe-assert (eqv? n 0)) + (emit ld (constant pb-int64) dest `(reg . ,breg) `(reg . ,ireg) code*)] + [else (bad!)])] + [(ax-reg? src) + (record-case dest + [(disp) (n breg) + (safe-assert (signed16? n)) + (emit st (constant pb-int64) `(reg . ,breg) `(imm ,n) src code*)] + [(index) (n ireg breg) + (safe-assert (eqv? n 0)) + (emit st (constant pb-int64) `(reg . ,breg) `(reg . ,ireg) src code*)] + [else (bad!)])] + [else (bad!)])))) + + (define asm-add + (lambda (set-cc?) + (lambda (code* dest src0 src1) + (Trivit (dest src0 src1) + (emit add set-cc? dest src0 src1 code*))))) + + (define asm-sub + (lambda (op) + (lambda (code* dest src0 src1) + (Trivit (dest src0 src1) + (if (eq? op '-/eq) + (emit subz #t dest src0 src1 code*) + (emit sub (eq? op '-/ovfl) dest src0 src1 code*)))))) + + (define asm-mul + (lambda (set-cc?) + (lambda (code* dest src0 src1) + (Trivit (dest src0 src1) + (emit mul set-cc? dest src0 src1 code*))))) + + (define asm-div + (lambda (code* dest src0 src1) + (Trivit (dest src0 src1) + (emit div dest src0 src1 code*)))) + + (define asm-logical + (lambda (op) + (lambda (code* dest src0 src1) + (Trivit (dest src0 src1) + (case op + [(logand) (emit land dest src0 src1 code*)] + [(logor) (emit lior dest src0 src1 code*)] + [(logxor) (emit lxor dest src0 src1 code*)] + [(sll) (emit lsl dest src0 src1 code*)] + [(srl) (emit lsr dest src0 src1 code*)] + [(sra) (emit asr dest src0 src1 code*)] + [(slol) (emit lslo dest src0 src1 code*)] + [else ($oops 'asm-logical "unexpected ~s" op)]))))) + + (define asm-lognot + (lambda (code* dest src) + (Trivit (dest src) + (emit lnot dest src code*)))) + + (define-who asm-fl-cvt + (lambda (op) + (lambda (code* dest src) + (Trivit (dest src) + (case op + [(single->double) + (emit mov.s->d dest src code*)] + [(double->single) + (emit mov.d->s dest src code*)] + [else (sorry! who "unrecognized op ~s" op)]))))) + + (define-who asm-load + (lambda (type) + (lambda (code* dest base index/offset) + (Trivit (dest base index/offset) + (case type + [(integer-64 unsigned-64) (emit ld (constant pb-int64) dest base index/offset code*)] + [(integer-32) (emit ld (constant pb-int32) dest base index/offset code*)] + [(unsigned-32) (emit ld (constant pb-uint32) dest base index/offset code*)] + [(integer-16) (emit ld (constant pb-int16) dest base index/offset code*)] + [(unsigned-16) (emit ld (constant pb-uint16) dest base index/offset code*)] + [(integer-8) (emit ld (constant pb-int8) dest base index/offset code*)] + [(unsigned-8) (emit ld (constant pb-uint8) dest base index/offset code*)] + [(double) (emit ld (constant pb-double) dest base index/offset code*)] + [(float) (emit ld (constant pb-single) dest base index/offset code*)] + [else (sorry! who "unexpected mref type ~s" type)]))))) + + (define-who asm-store + (lambda (type) + (lambda (code* base index/offset src) + (Trivit (base index/offset src) + (case type + [(integer-64 unsigned-64) (emit st (constant pb-int64) base index/offset src code*)] + [(integer-32 unsigned-32) (emit st (constant pb-int32) base index/offset src code*)] + [(integer-16 unsigned-16) (emit st (constant pb-int16) base index/offset src code*)] + [(integer-8 unsigned-8) (emit st (constant pb-int8) base index/offset src code*)] + [(double) (emit st (constant pb-double) base index/offset src code*)] + [(float) (emit st (constant pb-single) base index/offset src code*)] + [else (sorry! who "unexpected mref type ~s" type)]))))) + + (define-who asm-fpop-2 + (lambda (op) + (lambda (code* dest src1 src2) + (Trivit (dest src1 src2) + (case op + [(fp+) (emit fadd dest src1 src2 code*)] + [(fp-) (emit fsub dest src1 src2 code*)] + [(fp*) (emit fmul dest src1 src2 code*)] + [(fp/) (emit fdiv dest src1 src2 code*)] + [else (sorry! who "unrecognized op ~s" op)]))))) + + (define asm-fpsqrt + (lambda (code* dest src) + (Trivit (dest src) + (emit fsqrt dest src code*)))) + + (define asm-fptrunc + (lambda (code* dest src) + (Trivit (dest src) + (emit mov.d->i dest src code*)))) + + (define asm-fpt + (lambda (code* dest src) + (Trivit (dest src) + (emit mov.i->d dest src code*)))) + + (define-who asm-fpmove + ;; fpmove pseudo instruction is used by set! case in + ;; select-instructions! and generate-code; at most one of src or + ;; dest can be an mref + (lambda (code* dest src) + (gen-fpmove who code* dest src #t))) + + (define-who asm-fpmove-single + (lambda (code* dest src) + (gen-fpmove who code* dest src #f))) + + (define gen-fpmove + (lambda (who code* dest src double?) + (Trivit (dest src) + (record-case dest + [(disp) (imm reg) + (emit st (if double? (constant pb-double) (constant pb-single)) `(reg . ,reg) `(imm ,imm) src code*)] + [(index) (n ireg breg) + (emit st (if double? (constant pb-double) (constant pb-single)) `(reg . ,breg) `(reg . ,ireg) src code*)] + [else + (record-case src + [(disp) (imm reg) + (emit ld (if double? (constant pb-double) (constant pb-single)) dest `(reg . ,reg) `(imm ,imm) code*)] + [(index) (n ireg breg) + (emit ld (if double? (constant pb-double) (constant pb-single)) dest `(reg . ,breg) `(reg . ,ireg) code*)] + [else (emit fpmov dest src code*)])])))) + + (constant-case ptr-bits + [(64) + (define asm-fpcastto + (lambda (code* dest src) + (Trivit (dest src) + (emit mov.d*>i dest src code*)))) + + (define asm-fpcastfrom + (lambda (code* dest src) + (Trivit (dest src) + (emit mov.i*>d dest src code*))))] + [(32) + (define asm-fpcastto + (lambda (part) + (lambda (code* dest src) + (Trivit (dest src) + (if (eq? part 'hi) + (emit mov.d*h>i dest src code*) + (emit mov.d*l>i dest src code*)))))) + + (define asm-fpcastfrom + (lambda (code* dest src-lo src-hi) + (Trivit (dest src-lo src-hi) + (emit mov.ii*>d dest src-lo src-hi code*))))]) + + (define-who asm-swap + (lambda (type) + (lambda (code* dest src) + (Trivit (dest src) + (case type + [(integer-64 unsigned-64) (emit rev (constant pb-int64) dest src code*)] + [(integer-32) (emit rev (constant pb-int32) dest src code*)] + [(unsigned-32) (emit rev (constant pb-uint32) dest src code*)] + [(integer-16) (emit rev (constant pb-int16) dest src code*)] + [(unsigned-16) (emit rev (constant pb-uint16) dest src code*)] + [else (sorry! who "unexpected asm-swap type argument ~s" type)]))))) + + (define asm-inc! + (lambda (code* dest src) + (Trivit (dest src) + (emit inc dest src code*)))) + + (define asm-lock! + (lambda (info) + (lambda (l1 l2 offset dest) + (values + (Trivit (dest) + (emit lock dest '())) + (asm-conditional-jump info l1 l2 offset))))) + + (define asm-cas! + (lambda (code* dest old new) + (Trivit (dest old new) + (emit cas dest old new code*)))) + + (define-who asm-relop + (lambda (info) + (lambda (l1 l2 offset x y) + (values + (Trivit (x y) + (define-syntax sel + (lambda (stx) + (syntax-case stx () + [(_ pos neg) + #`(if (info-condition-code-reversed? info) + (emit neg x y '()) + (emit pos x y '()))]))) + (case (info-condition-code-type info) + [(eq?) (emit eq x y '())] + [(u<) (sel bl ab)] + [(<) (sel lt gt)] + [(>) (sel gt lt)] + [(<=) (sel le ge)] + [(>=) (sel ge le)] + [(logtest) (emit cs x y '())] + [(log!test) (emit cc x y '())] + [else (sorry! who "unexpected ~s" (info-condition-code-type info))])) + (asm-conditional-jump info l1 l2 offset))))) + + (define-who asm-fp-relop + (lambda (info) + (lambda (l1 l2 offset x y) + (Trivit (x y) + (values + (case (info-condition-code-type info) + [(fp=) (emit fpeq x y '())] + [(fp<) (emit fplt x y '())] + [(fp<=) (emit fple x y '())] + [else (sorry! who "unrecognized ~s" (info-condition-code-type info))]) + (asm-conditional-jump info l1 l2 offset)))))) + + (define asm-condition-code + (lambda (info) + (rec asm-check-flag-internal + (lambda (l1 l2 offset) + (values '() (asm-conditional-jump info l1 l2 offset)))))) + + (define asm-library-jump + (lambda (l) + (asm-helper-jump '() + `(pb-proc ,(constant code-data-disp) (library-code ,(libspec-label-libspec l)))))) + + (define asm-library-call + (lambda (libspec) + (let ([target `(pb-proc ,(constant code-data-disp) (library-code ,libspec))]) + (lambda (code* dest jmptmp . ignore) + (asm-helper-call code* jmptmp #t target))))) + + (define asm-library-call! + (lambda (libspec) + (let ([target `(pb-proc ,(constant code-data-disp) (library-code ,libspec))]) + (lambda (code* jmptmp . ignore) + (asm-helper-call code* jmptmp #t target))))) + + (define asm-c-simple-call + (lambda (entry) + (let ([target `(pb-proc 0 (entry ,entry))]) + (lambda (code* jmptmp . ignore) + (asm-helper-call code* jmptmp #f target))))) + + (define-who asm-indirect-call + (lambda (code* dest proto . ignore) + (Trivit (dest proto) + (unless (ax-reg? dest) (sorry! who "unexpected dest ~s" dest)) + (emit call dest proto code*)))) + + (define asm-direct-jump + (lambda (l offset) + (let ([offset (adjust-return-point-offset offset l)]) + (asm-helper-jump '() (make-funcrel 'pb-proc l offset))))) + + (define asm-literal-jump + (lambda (info) + (asm-helper-jump '() + `(pb-proc ,(info-literal-offset info) (,(info-literal-type info) ,(info-literal-addr info)))))) + + (define-who asm-indirect-jump + (lambda (src) + (Trivit (src) + (record-case src + [(reg) ignore (emit b src '())] + [(disp) (n breg) + (assert (signed16? n)) + (emit b* `(reg . ,breg) `(imm ,n) '())] + [(index) (n ireg breg) + (safe-assert (eqv? n 0)) + (emit b* `(reg . ,breg) `(reg . ,ireg) '())] + [else (sorry! who "unexpected src ~s" src)])))) + + (define-who asm-return-address + (lambda (dest l incr-offset next-addr) + (make-rachunk dest l incr-offset next-addr + (cond + [(local-label-offset l) => + (lambda (offset) + (let ([incr-offset (adjust-return-point-offset incr-offset l)]) + (let ([disp (fx- next-addr (fx- offset incr-offset))]) + (emit adr `(reg . ,dest) disp '()))))] + [else + (asm-move '() dest (with-output-language (L16 Triv) `(label-ref ,l ,incr-offset)))])))) + + (define-who asm-jump + (lambda (l next-addr) + (make-gchunk l next-addr + (cond + [(local-label-offset l) => + (lambda (offset) + (let ([disp (fx- next-addr offset)]) + (cond + [(eqv? disp 0) '()] + [else + (safe-assert (signed24? disp)) + (emit b `(label ,disp ,l) '())])))] + [else + ;; label must be somewhere above. generate something so that a hard loop + ;; doesn't get dropped. this also has some chance of being the right size + ;; for the final branch instruction. + (emit b `(label 0 ,l) '())])))) + + (define-who asm-conditional-jump + (lambda (info l1 l2 next-addr) + (make-cgchunk info l1 l2 next-addr + (let () + (define get-disp-opnd + (lambda (next-addr l) + (if (local-label? l) + (cond + [(local-label-offset l) => + (lambda (offset) + (let ([disp (fx- next-addr offset)]) + (safe-assert (signed24? disp)) + (values disp `(label ,disp ,l))))] + [else (values 0 `(label 0 ,l))]) + (sorry! who "unexpected label ~s" l)))) + + (let-values ([(disp1 opnd1) (get-disp-opnd next-addr l1)] + [(disp2 opnd2) (get-disp-opnd next-addr l2)]) + (cond + [(fx= disp1 0) + (emit bfals opnd2 '())] + [(fx= disp2 0) + (emit btrue opnd1 '())] + [else + (let-values ([(disp1 opnd1) (get-disp-opnd (fx+ next-addr 4) l1)]) + (emit btrue opnd1 (emit b opnd2 '())))])))))) + + (define asm-helper-jump + (lambda (code* reloc) + (let ([jmptmp (cons 'reg %ts)]) + (ax-mov64 jmptmp 0 + (emit b jmptmp + (asm-helper-relocation code* reloc)))))) + + (define asm-helper-call + (lambda (code* jmptmp interp? reloc) + (ax-mov64 `(reg . ,jmptmp) 0 + (let ([code* (asm-helper-relocation code* reloc)]) + (if interp? + (emit interp `(reg . ,jmptmp) code*) + (emit call `(reg . ,jmptmp) `(imm ,(constant pb-call-void)) code*)))))) + + (define asm-helper-relocation + (lambda (code* reloc) + (cons* reloc (aop-cons* `(asm "relocation:" ,reloc) code*)))) + + (define asm-return (lambda () (emit ret '()))) + + (define asm-c-return (lambda (info) (emit ret '()))) + + (define asm-enter values) + + (define asm-kill + (lambda (code* dest) + code*)) + + (module (asm-foreign-call asm-foreign-callable) + (define int-argument-regs (lambda () (list %Carg1 %Carg2 %Carg3 %Carg4 %Carg5 %Carg6 %Carg7))) + (define fp-argument-regs (lambda () (list %Cfparg1 %Cfparg2 %Cfparg3 %Cfparg4 %Cfparg5 %Cfparg6))) + + (define prototypes (constant pb-prototype-table)) + + (define-who asm-foreign-call + (with-output-language (L13 Effect) + (letrec ([load-double-reg + (lambda (fpreg) + (lambda (x) ; unboxed + `(set! ,fpreg ,x)))] + [load-int-reg + (lambda (ireg) + (lambda (x) + `(set! ,ireg ,x)))] + [load-two-int-regs + (lambda (lo-ireg hi-ireg) + (lambda (lo hi) + `(seq + (set! ,lo-ireg ,lo) + (set! ,hi-ireg ,hi))))] + [64-bit-type-on-32-bit? + (lambda (type) + (nanopass-case (Ltype Type) type + [(fp-integer ,bits) + (constant-case ptr-bits + [(64) #f] + [(32) (fx= bits 64)])] + [(fp-integer ,bits) + (constant-case ptr-bits + [(64) #f] + [(32) (fx= bits 64)])] + [else #f]))] + [do-args + (lambda (in-types) + (let loop ([types in-types] [locs '()] [live* '()] [int* (int-argument-regs)] [fp* (fp-argument-regs)]) + (if (null? types) + (values locs live*) + (let ([type (car types)] + [types (cdr types)]) + (nanopass-case (Ltype Type) type + [(fp-double-float) + (when (null? fp*) (sorry! who "too many floating-point arguments")) + (loop types + (cons (load-double-reg (car fp*)) locs) + (cons (car fp*) live*) + int* (cdr fp*))] + [(fp-single-float) + (when (null? fp*) (sorry! who "too many floating-point arguments")) + (loop types + (cons (load-double-reg (car fp*)) locs) + (cons (car fp*) live*) + int* (cdr fp*))] + [(fp-ftd& ,ftd) + (sorry! who "indirect arguments no supported")] + [else + (when (null? int*) (sorry! who "too many integer/pointer arguments: ~s" (length in-types))) + (cond + [(64-bit-type-on-32-bit? type) + (when (null? (cdr int*)) (sorry! who "too many integer/pointer arguments: ~s" (length in-types))) + (loop types + (cons (load-two-int-regs (car int*) (cadr int*)) locs) + (cons* (cadr int*) (car int*) live*) + (cddr int*) fp*)] + [else + (loop types + (cons (load-int-reg (car int*)) locs) + (cons (car int*) live*) + (cdr int*) fp*)])])))))] + [do-result + (lambda (type) + (nanopass-case (Ltype Type) type + [(fp-double-float) + (values (lambda (lvalue) ; unboxed + `(set! ,lvalue ,%Cfpretval)) + (list %Cfpretval))] + [(fp-single-float) + (values (lambda (lvalue) ; unboxed + `(set! ,lvalue ,(%inline single->double ,%Cfpretval))) + (list %Cfpretval))] + [(fp-ftd& ,ftd) + (sorry! who "unhandled result type ~s" type)] + [else + (when (64-bit-type-on-32-bit? type) + (sorry! who "unhandled result type ~s" type)) + (values (lambda (lvalue) `(set! ,lvalue ,%Cretval)) + (list %Cretval))]))] + [get-prototype + (lambda (type*) + (let* ([prototype + (map (lambda (type) + (nanopass-case (Ltype Type) type + [(fp-double-float) 'double] + [(fp-single-float) 'float] + [(fp-integer ,bits) + (constant-case ptr-bits + [(64) (case bits + [(8) 'int8] + [(16) 'int16] + [(32) 'int32] + [else 'uptr])] + [(32) (case bits + [(8) 'int8] + [(16) 'int16] + [(32) 'uptr] + [else 'int64])])] + [(fp-unsigned ,bits) + (constant-case ptr-bits + [(64) (case bits + [(8) 'uint8] + [(16) 'uint16] + [(32) 'uint32] + [else 'uptr])] + [(32) (case bits + [(8) 'uint8] + [(16) 'uint16] + [(32) 'uptr] + [else 'int64])])] + [(fp-scheme-object) 'uptr] + [(fp-fixnum) 'uptr] + [(fp-u8*) 'void*] + [(fp-void) 'void] + [else (sorry! who "unhandled type in prototype ~s" type)])) + type*)] + [a (assoc prototype prototypes)]) + (unless a + (sorry! who "unsupported prototype ~a" prototype)) + (cdr a)))]) + (lambda (info) + (let* ([arg-type* (info-foreign-arg-type* info)] + [result-type (info-foreign-result-type info)]) + (let-values ([(locs arg-live*) (do-args arg-type*)] + [(get-result result-live*) (do-result result-type)]) + (values + (lambda () `(nop)) + (reverse locs) + (lambda (t0 not-varargs?) + (let ([info (make-info-kill*-live* (add-caller-save-registers result-live*) arg-live*)]) + `(inline ,info ,%c-call ,t0 (immediate ,(get-prototype (cons result-type arg-type*)))))) + get-result + (lambda () `(nop))))))))) + + (define-who asm-foreign-callable + (lambda (info) + (sorry! who "callables are not supported")))) +) diff --git a/s/primdata.ss b/s/primdata.ss index c7772d750e..38582473a3 100644 --- a/s/primdata.ss +++ b/s/primdata.ss @@ -1955,6 +1955,8 @@ ($foreign-entries [flags single-valued]) ($foreign-entry [flags single-valued discard]) ($foreign-wchar? [sig [(ptr) -> (boolean)]] [flags pure unrestricted cp02]) + ($foreign-swap-ref [sig [(sub-symbol uptr/iptr uptr/iptr) -> (ptr)]] [flags]) + ($foreign-swap-set! [sig [(sub-symbol uptr/iptr uptr/iptr sub-ptr) -> (void)]] [flags true]) ($format-scheme-version [flags single-valued alloc]) ($fp-filter-type [flags single-valued]) ($fp-string->utf16 [flags single-valued]) diff --git a/s/prims.ss b/s/prims.ss index 1496e74913..22909f79fb 100644 --- a/s/prims.ss +++ b/s/prims.ss @@ -59,7 +59,10 @@ scheme-object)) (define weak-pair? - (lambda (p) (weak-pair? p))) + (constant-case architecture + [(pb) + (foreign-procedure "(cs)s_weak_pairp" (scheme-object) scheme-object)] + [else (lambda (p) (weak-pair? p))])) (define ephemeron-cons (foreign-procedure "(cs)s_ephemeron_cons" @@ -67,7 +70,11 @@ scheme-object)) (define ephemeron-pair? - (lambda (p) (ephemeron-pair? p))) + (constant-case architecture + [(pb) + (foreign-procedure "(cs)s_ephemeron_pairp" (scheme-object) scheme-object)] + [else + (lambda (p) (ephemeron-pair? p))])) (define $split-continuation (foreign-procedure "(cs)single_continuation" @@ -2040,28 +2047,48 @@ (define-tlc-parameter $tlc-next $set-tlc-next!) ) - -(define $generation - (lambda (x) - ($generation x))) -(define $maybe-seginfo - (lambda (x) - ($maybe-seginfo x))) -(define $seginfo - (lambda (x) - ($seginfo x))) -(define $seginfo-generation - (lambda (x) - ($seginfo-generation x))) -(define $seginfo-space - (lambda (x) - ($seginfo-space x))) -(define-who $list-bits-ref - (lambda (x) - (unless (pair? x) ($oops who "~s is not a pair" x)) - ($list-bits-ref x))) -(define-who $list-bits-set! - (foreign-procedure "(cs)list_bits_set" (ptr iptr) void)) +(constant-case architecture + [(pb) + ;; can't inline seginfo access + (define-who $maybe-seginfo + (lambda (x) ($oops who "unsupported for pb"))) + (define-who $seginfo + (lambda (x) ($oops who "unsupported for pb"))) + (define-who $seginfo-generation + (lambda (x) ($oops who "unsupported for pb"))) + (define-who $seginfo-space + (lambda (x) ($oops who "unsupported for pb"))) + (define-who $generation + (foreign-procedure "(cs)generation" (scheme-object) scheme-object)) + (define-who $list-bits-ref + (let ([list_bits_ref (foreign-procedure "(cs)list_bits_ref" (ptr) ptr)]) + (lambda (x) + (unless (pair? x) ($oops who "~s is not a pair" x)) + (list_bits_ref x)))) + (define-who $list-bits-set! + (foreign-procedure "(cs)list_bits_set" (ptr iptr) void))] + [else + (define $generation + (lambda (x) + ($generation x))) + (define $maybe-seginfo + (lambda (x) + ($maybe-seginfo x))) + (define $seginfo + (lambda (x) + ($seginfo x))) + (define $seginfo-generation + (lambda (x) + ($seginfo-generation x))) + (define $seginfo-space + (lambda (x) + ($seginfo-space x))) + (define-who $list-bits-ref + (lambda (x) + (unless (pair? x) ($oops who "~s is not a pair" x)) + ($list-bits-ref x))) + (define-who $list-bits-set! + (foreign-procedure "(cs)list_bits_set" (ptr iptr) void))]) (let () (define $phantom-bytevector-adjust! @@ -2153,7 +2180,7 @@ (lambda (s) (unless (string? s) ($oops 'get-registry "~s is not a string" s)) (let ([x (fp s)]) - (and x (utf16->string x (constant native-endianness))))))) + (and x (utf16->string x (native-endianness))))))) (define put-registry! (let ([fp (foreign-procedure "(windows)PutRegistry" @@ -2440,7 +2467,7 @@ [else (string-set! s j (integer->char w1)) (loop (fx+ i 2) (fx+ j 1))]))]))])) - (if (eq? eness (constant native-endianness)) + (if (eq? eness (native-endianness)) (go bytevector-u16-native-ref) (go (lambda (bv i) (bytevector-u16-ref bv i eness)))))))) (rec utf16->string @@ -2453,9 +2480,9 @@ (slurp bv eness 0) (let ([BOM (bytevector-u16-native-ref bv 0)]) (if (fx= BOM #xfeff) - (slurp bv (constant native-endianness) 2) + (slurp bv (native-endianness) 2) (if (fx= BOM #xfffe) - (slurp bv (constant-case native-endianness [(big) 'little] [(little) 'big]) 2) + (slurp bv (case (native-endianness) [(big) 'little] [(little) 'big]) 2) (slurp bv eness 0)))))])))) (let () @@ -2489,7 +2516,7 @@ (bv-u16-set! bv bvi (fxior #xD800 (fxsrl x 10))) (bv-u16-set! bv (fx+ bvi 2) (fxior #xDC00 (fxand x #x3ff))) (f (fx+ si 1) (fx+ bvi 4)))))))])) - (if (eq? eness (constant native-endianness)) + (if (eq? eness (native-endianness)) (go bytevector-u16-native-set!) (go (lambda (bv i n) (bytevector-u16-set! bv i n eness)))) bv))) @@ -2529,7 +2556,7 @@ (integer->char x) #\xfffd)) (loop (fx+ i 4) (fx+ j 1)))]))])) - (if (eq? eness (constant native-endianness)) + (if (eq? eness (native-endianness)) (go bytevector-u32-native-ref) (go (lambda (bv i) (bytevector-u32-ref bv i eness)))))))) (rec utf32->string @@ -2542,9 +2569,9 @@ (slurp bv eness 0) (let ([BOM (bytevector-u32-native-ref bv 0)]) (if (and (fixnum? BOM) (fx= BOM #xfeff)) - (slurp bv (constant native-endianness) 4) + (slurp bv (native-endianness) 4) (if (= BOM #xfffe0000) - (slurp bv (constant-case native-endianness [(big) 'little] [(little) 'big]) 4) + (slurp bv (case (native-endianness) [(big) 'little] [(little) 'big]) 4) (slurp bv eness 0)))))])))) (let () @@ -2563,7 +2590,7 @@ (do ([si 0 (fx+ si 1)]) ((fx= si sn)) (bv-u32-set! bv (fxsll si 2) (char->integer (string-ref s si))))])) - (if (eq? eness (constant native-endianness)) + (if (eq? eness (native-endianness)) (go bytevector-u32-native-set!) (go (lambda (bv i n) (bytevector-u32-set! bv i n eness)))) bv))) diff --git a/s/record.ss b/s/record.ss index 140f386c16..d863fb739e 100644 --- a/s/record.ss +++ b/s/record.ss @@ -50,6 +50,109 @@ (rtd-flds prtd) 0))) + (define-syntax native-endianness-case + (lambda (stx) + (syntax-case stx (big little) + [(_ [(big) b ...] [(little) l ...]) + #`(constant-case native-endianness + [(big) b ...] + [(little) l ...] + [(unknown) + (case (native-endianness) + [(big) b ...] + [(little) l ...])])]))) + + (define-syntax build-multi-int + (lambda (stx) + (syntax-case stx () + [(moi (ref/set r offset arg ...) signed wide-bits narrow-bits swap?) + #`(moi (ref/set r offset arg ...) signed wide-bits 0 narrow-bits swap?)] + [(moi (ref/set r offset arg ...) signed wide-bits middle-bits narrow-bits swap?) + (let ([mk (lambda (base n) + (datum->syntax #'moi (string->symbol (format "~a-~a" base n))))]) + (cond + [(not (datum swap?)) + (with-syntax ([signed-wide (mk (datum signed) (datum wide-bits))] + [unsigned-wide (mk 'unsigned (datum wide-bits))] + [unsigned-middle (mk 'unsigned (datum middle-bits))] + [signed-narrow (mk (datum signed) (datum narrow-bits))] + [unsigned-narrow (mk 'unsigned (datum narrow-bits))] + [wide-bytes (fxsrl (datum wide-bits) 3)] + [middle-bytes (fxsrl (datum middle-bits) 3)] + [narrow-bytes (fxsrl (datum narrow-bits) 3)]) + (with-syntax ([big-case + (cond + [(null? #'(arg ...)) + ;; ref mode + #`(logor + (ash (ref/set 'signed-wide r offset) (+ narrow-bits middle-bits)) + #,(if (zero? (datum middle-bits)) + #`0 + #`(ash (ref/set 'unsigned-middle r (fx+ offset wide-bytes)) narrow-bits)) + (ref/set 'unsigned-narrow r (fx+ offset wide-bytes middle-bytes)))] + [else + ;; set mode + #`(begin + (ref/set 'signed-wide r offset + (bitwise-arithmetic-shift-right arg ... (+ narrow-bits middle-bits))) + #,(if (zero? (datum middle-bits)) + #`(void) + #`(ref/set 'unsigned-middle r (fx+ offset wide-bytes) + (logand (bitwise-arithmetic-shift-right arg ... narrow-bits) + (- (expt 2 middle-bits) 1)))) + (ref/set 'unsigned-narrow r (fx+ offset middle-bytes wide-bytes) + (logand arg ... (- (expt 2 narrow-bits) 1))))])] + [little-case + (cond + [(null? #'(arg ...)) + ;; ref mode + #`(logor + (ref/set 'unsigned-wide r offset) + #,(if (zero? (datum middle-bits)) + 0 + #`(ash (ref/set 'unsigned-middle r (fx+ offset wide-bytes)) wide-bits)) + (ash (ref/set 'signed-narrow r (fx+ offset wide-bytes middle-bytes)) (+ wide-bits middle-bits)))] + [else + ;; set mode + #`(begin + (ref/set 'unsigned-wide r offset + (logand arg ... (- (expt 2 wide-bits) 1))) + #,(if (zero? (datum middle-bits)) + #`(void) + #`(ref/set 'unsigned-middle r (fx+ offset wide-bytes) + (logand (bitwise-arithmetic-shift-right arg ... wide-bits) + (- (expt 2 middle-bits) 1)))) + (ref/set 'signed-narrow r (fx+ offset middle-bytes wide-bytes) + (bitwise-arithmetic-shift-right arg ... (+ wide-bits middle-bits))))])]) + #'(native-endianness-case + [(big) big-case] + [(little) little-case])))] + [else + ;; For swap mode, perform a sequence of byte reads or writes + (let ([mk (lambda (big?) + (let* ([bits (+ (datum wide-bits) (datum middle-bits) (datum narrow-bits))] + [bytes (fxsrl bits 3)]) + (let gen ([bits bits] + [type (mk (datum signed) 8)] + [shift (- bits 8)] + [delta (if big? 0 (- bytes 1))]) + (cond + [(= bits 8) + (cond + [(null? #'(arg ...)) + ;; ref mode + #`(ash (ref/set '#,type r (fx+ offset #,delta)) #,shift)] + [else + ;; set mode + #`(ref/set '#,type r (fx+ offset #,delta) (logand #xff (bitwise-arithmetic-shift-right arg ... #,shift)))])] + [else + #`(#,(if (null? #'(arg ...)) #'logor #'begin) + #,(gen 8 type shift delta) + #,(gen (- bits 8) (mk 'unsigned 8) (- shift 8) (+ delta (if big? 1 -1))))]))))]) + #`(native-endianness-case + [(big) #,(mk #t)] + [(little) #,(mk #f)]))]))]))) + ; $record is hand-coded and is defined in prims.ss (let ([addr? (constant-case ptr-bits @@ -80,163 +183,171 @@ (unless (addr? (+ addr offset)) ($oops who "invalid effective address (+ ~s ~s)" addr offset)) (record-datatype cases (filter-foreign-type ty) check-ending-addr ($oops who "unrecognized type ~s" ty))) - (set-who! foreign-ref ; checks ty, addr, and offset, but inherently unsafe - (lambda (ty addr offset) - (define-syntax ref - (syntax-rules (scheme-object char wchar boolean integer-64 unsigned-64) - [(_ scheme-object bytes pred) ($oops who "cannot load scheme pointers from foreign memory")] - [(_ char bytes pred) (integer->char (#3%foreign-ref 'unsigned-8 addr offset))] - [(_ wchar bytes pred) - (constant-case wchar-bits - [(16) (integer->char (#3%foreign-ref 'unsigned-16 addr offset))] - [(32) (integer->char (#3%foreign-ref 'unsigned-32 addr offset))])] - [(_ boolean bytes pred) - (constant-case int-bits - [(32) (not (eq? (#3%foreign-ref 'integer-32 addr offset) 0))] - [(64) (not (eq? (#3%foreign-ref 'integer-64 addr offset) 0))])] - [(_ integer-64 bytes pred) - (< (constant ptr-bits) 64) - (constant-case native-endianness - [(big) - (logor (ash (#3%foreign-ref 'integer-32 addr offset) 32) - (#3%foreign-ref 'unsigned-32 (+ addr 4) offset))] - [(little) - (logor (ash (#3%foreign-ref 'integer-32 (+ addr 4) offset) 32) - (#3%foreign-ref 'unsigned-32 addr offset))])] - [(_ unsigned-64 bytes pred) - (< (constant ptr-bits) 64) - (constant-case native-endianness - [(big) - (logor (ash (#3%foreign-ref 'unsigned-32 addr offset) 32) - (#3%foreign-ref 'unsigned-32 (+ addr 4) offset))] - [(little) - (logor (ash (#3%foreign-ref 'unsigned-32 (+ addr 4) offset) 32) - (#3%foreign-ref 'unsigned-32 addr offset))])] - [(_ type bytes pred) (#3%foreign-ref 'type addr offset)])) - (check-args who ty addr offset) - (record-datatype cases (filter-foreign-type ty) ref - ($oops who "unrecognized type ~s" ty)))) + (let () + (define-syntax set-foreign-ref! + (syntax-rules () + [(_ foreign-ref swap?) + (set-who! foreign-ref ; checks ty, addr, and offset, but inherently unsafe + (lambda (ty addr offset) + (define-syntax ref + (syntax-rules (scheme-object char wchar boolean + integer-24 unsigned-24 integer-40 unsigned-40 integer-48 unsigned-48 + integer-56 unsigned-56 integer-64 unsigned-64) + [(_ scheme-object bytes pred) ($oops who "cannot load scheme pointers from foreign memory")] + [(_ char bytes pred) (integer->char (#3%foreign-ref 'unsigned-8 addr offset))] + [(_ wchar bytes pred) + (constant-case wchar-bits + [(16) (integer->char (#3%foreign-ref 'unsigned-16 addr offset))] + [(32) (integer->char (#3%foreign-ref 'unsigned-32 addr offset))])] + [(_ boolean bytes pred) + (constant-case int-bits + [(32) (not (eq? (#3%foreign-ref 'integer-32 addr offset) 0))] + [(64) (not (eq? (#3%foreign-ref 'integer-64 addr offset) 0))])] + [(_ integer-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) integer 16 8 swap?)] + [(_ unsigned-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) unsigned 16 8 swap?)] + [(_ integer-40 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) integer 32 8 swap?)] + [(_ unsigned-40 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) unsigned 32 8 swap?)] + [(_ integer-48 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) integer 32 16 swap?)] + [(_ unsigned-48 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) unsigned 32 16 swap?)] + [(_ integer-56 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) integer 32 16 8 swap?)] + [(_ unsigned-56 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%foreign-ref addr offset) unsigned 32 16 8 swap?)] + [(_ integer-64 bytes pred) + (< (constant ptr-bits) 64) + (build-multi-int (#3%foreign-ref addr offset) integer 32 32 swap?)] + [(_ unsigned-64 bytes pred) + (< (constant ptr-bits) 64) + (build-multi-int (#3%foreign-ref addr offset) unsigned 32 32 swap?)] + [(_ type bytes pred) (#3%foreign-ref 'type addr offset)])) + (check-args who ty addr offset) + (record-datatype cases (filter-foreign-type ty) ref + ($oops who "unrecognized type ~s" ty))))])) + (set-foreign-ref! foreign-ref #f) + ;; Only used for slow cases of `$fptr-ref-...` + (set-foreign-ref! $foreign-swap-ref #t)) - (set-who! foreign-set! ; checks ty, addr, offset, and v, but inherently unsafe - (lambda (ty addr offset v) - (define (value-err x t) ($oops who "invalid value ~s for foreign type ~s" x t)) - (define-syntax set - (syntax-rules (scheme-object char wchar boolean integer-40 unsigned-40 integer-48 unsigned-48 - integer-56 unsigned-56 integer-64 unsigned-64) - [(_ scheme-object bytes pred) ($oops who "cannot store scheme pointers into foreign memory")] - [(_ char bytes pred) - (begin - (unless (pred v) (value-err v ty)) - (#3%foreign-set! 'unsigned-8 addr offset (char->integer v)))] - [(_ wchar bytes pred) - (begin - (unless (pred v) (value-err v ty)) - (constant-case wchar-bits - [(16) (#3%foreign-set! 'unsigned-16 addr offset (char->integer v))] - [(32) (#3%foreign-set! 'unsigned-32 addr offset (char->integer v))]))] - [(_ boolean bytes pred) - (constant-case int-bits - [(32) (#3%foreign-set! 'integer-32 addr offset (if v 1 0))] - [(64) (#3%foreign-set! 'integer-64 addr offset (if v 1 0))])] - [(_ integer-40 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 8)) - (#3%foreign-set! 'unsigned-8 (+ addr 4) offset (logand v (- (expt 2 8) 1)))] - [(little) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) - (#3%foreign-set! 'integer-8 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] - [(_ unsigned-40 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 8)) - (#3%foreign-set! 'unsigned-8 (+ addr 4) offset (logand v (- (expt 2 8) 1)))] - [(little) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) - (#3%foreign-set! 'unsigned-8 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] - [(_ integer-48 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 16)) - (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand v (- (expt 2 16) 1)))] - [(little) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) - (#3%foreign-set! 'integer-16 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] - [(_ unsigned-48 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 16)) - (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand v (- (expt 2 16) 1)))] - [(little) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) - (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] - [(_ integer-56 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 24)) - (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) - (#3%foreign-set! 'unsigned-8 (+ addr 6) offset (logand v (- (expt 2 8) 1)))] - [(little) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) - (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) - (#3%foreign-set! 'integer-8 (+ addr 6) offset (bitwise-arithmetic-shift-right v 48))]))] - [(_ unsigned-56 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 24)) - (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) - (#3%foreign-set! 'unsigned-8 (+ addr 6) offset (logand v (- (expt 2 8) 1)))] - [(little) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) - (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) - (#3%foreign-set! 'unsigned-8 (+ addr 6) offset (bitwise-arithmetic-shift-right v 48))]))] - [(_ integer-64 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'integer-32 addr offset (ash v -32)) - (#3%foreign-set! 'unsigned-32 (+ addr 4) offset (logand v (- (expt 2 32) 1)))] - [(little) - (#3%foreign-set! 'integer-32 (+ addr 4) offset (ash v -32)) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))]))] - [(_ unsigned-64 bytes pred) - (< (constant ptr-bits) 64) - (begin - (unless (pred v) (value-err v ty)) - (constant-case native-endianness - [(big) - (#3%foreign-set! 'unsigned-32 addr offset (ash v -32)) - (#3%foreign-set! 'unsigned-32 (+ addr 4) offset (logand v (- (expt 2 32) 1)))] - [(little) - (#3%foreign-set! 'unsigned-32 (+ addr 4) offset (ash v -32)) - (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))]))] - [(_ type bytes pred) - (begin - (unless (pred v) (value-err v ty)) - (#3%foreign-set! 'type addr offset v))])) - (check-args who ty addr offset) - (record-datatype cases (filter-foreign-type ty) set - ($oops who "unrecognized type ~s" ty)))))) + (let () + (define-syntax set-foreign-set!! + (syntax-rules () + [(_ foreign-set! swap?) + (set-who! foreign-set! ; checks ty, addr, offset, and v, but inherently unsafe + (lambda (ty addr offset v) + (define (value-err x t) ($oops who "invalid value ~s for foreign type ~s" x t)) + (define-syntax set + (syntax-rules (scheme-object char wchar boolean + integer-24 unsigned-24 integer-40 unsigned-40 integer-48 unsigned-48 + integer-56 unsigned-56 integer-64 unsigned-64 double-float single-float) + [(_ scheme-object bytes pred) ($oops who "cannot store scheme pointers into foreign memory")] + [(_ char bytes pred) + (begin + (unless (pred v) (value-err v ty)) + (#3%foreign-set! 'unsigned-8 addr offset (char->integer v)))] + [(_ wchar bytes pred) + (begin + (unless (pred v) (value-err v ty)) + (constant-case wchar-bits + [(16) (#3%foreign-set! 'unsigned-16 addr offset (char->integer v))] + [(32) (#3%foreign-set! 'unsigned-32 addr offset (char->integer v))]))] + [(_ boolean bytes pred) + (constant-case int-bits + [(32) (#3%foreign-set! 'integer-32 addr offset (if v 1 0))] + [(64) (#3%foreign-set! 'integer-64 addr offset (if v 1 0))])] + [(_ integer-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) integer 16 8 swap?))] + [(_ unsigned-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) unsigned 16 8 swap?))] + [(_ integer-40 bytes pred) + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) integer 32 8 swap?))] + [(_ unsigned-40 bytes pred) + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) unsigned 32 8 swap?))] + [(_ integer-48 bytes pred) + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) integer 32 16 swap?))] + [(_ unsigned-48 bytes pred) + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) unsigned 32 16 swap?))] + [(_ integer-56 bytes pred) + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) integer 32 16 8 swap?))] + [(_ unsigned-56 bytes pred) + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) unsigned 32 16 8 swap?))] + [(_ integer-64 bytes pred) + (< (constant ptr-bits) 64) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) integer 32 32 swap?))] + [(_ unsigned-64 bytes pred) + (< (constant ptr-bits) 64) + (begin + (unless (pred v) (value-err v ty)) + (build-multi-int (#3%foreign-set! addr offset v) unsigned 32 32 swap?))] + [(_ double-float bytes pred) + (and swap? (< (constant ptr-bits) 64)) + (begin + (unless (pred v) (value-err v ty)) + (let ([bv (make-bytevector 8)]) + (bytevector-ieee-double-native-set! bv 0 v) + (foreign-set! 'unsigned-32 addr offset (bytevector-u32-native-ref bv 0)) + (foreign-set! 'unsigned-32 addr (fx+ offset 4) (bytevector-u32-native-ref bv 4))))] + [(_ single-float bytes pred) + swap? + (begin + (unless (pred v) (value-err v ty)) + (let ([bv (make-bytevector 4)]) + (bytevector-ieee-single-native-set! bv 0 v) + (foreign-set! 'unsigned-32 addr offset (bytevector-u32-native-ref bv 0))))] + [(_ type bytes pred) + (begin + (unless (pred v) (value-err v ty)) + (#3%foreign-set! 'type addr offset v))])) + (check-args who ty addr offset) + (record-datatype cases (filter-foreign-type ty) set + ($oops who "unrecognized type ~s" ty))))])) + (set-foreign-set!! foreign-set! #f) + ;; Only used for slow cases of `$fptr-set-...!` + (set-foreign-set!! $foreign-swap-set! #t)))) (set-who! $filter-foreign-type ; version that filters using host-machine information @@ -246,7 +357,9 @@ (set-who! $object-ref ; not safe, just handles non-constant types (lambda (ty r offset) (define-syntax ref - (syntax-rules (char wchar boolean integer-64 unsigned-64) + (syntax-rules (char wchar boolean + integer-24 unsigned-24 integer-40 unsigned-40 integer-48 unsigned-48 + integer-56 unsigned-56 integer-64 unsigned-64) [(_ char bytes pred) (integer->char (#3%$object-ref 'unsigned-8 r offset))] [(_ wchar bytes pred) (constant-case wchar-bits @@ -256,6 +369,30 @@ (constant-case int-bits [(32) (not (eq? (#3%$object-ref 'integer-32 r offset) 0))] [(64) (not (eq? (#3%$object-ref 'integer-64 r offset) 0))])] + [(_ integer-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) integer 16 8 #f)] + [(_ unsigned-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) unsigned 16 8 #f)] + [(_ integer-40 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) integer 32 8 #f)] + [(_ unsigned-40 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) unsigned 32 8 #f)] + [(_ integer-48 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) integer 32 16 #f)] + [(_ unsigned-48 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) unsigned 32 16 #f)] + [(_ integer-56 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) integer 32 16 8 #f)] + [(_ unsigned-56 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-ref r offset) unsigned 32 16 8 #f)] [(_ type bytes pred) (#3%$object-ref 'type r offset)])) (record-datatype cases (filter-foreign-type ty) ref ($oops who "unrecognized type ~s" ty)))) @@ -263,7 +400,9 @@ (set-who! $swap-object-ref ; not safe, just handles non-constant types (lambda (ty r offset) (define-syntax ref - (syntax-rules (char wchar boolean integer-64 unsigned-64) + (syntax-rules (char wchar boolean + integer-24 unsigned-24 integer-40 unsigned-40 integer-48 unsigned-48 + integer-56 unsigned-56 integer-64 unsigned-64) [(_ char bytes pred) (integer->char (#3%$swap-object-ref 'unsigned-8 r offset))] [(_ wchar bytes pred) (constant-case wchar-bits @@ -273,6 +412,30 @@ (constant-case int-bits [(32) (not (eq? (#3%$swap-object-ref 'integer-32 r offset) 0))] [(64) (not (eq? (#3%$swap-object-ref 'integer-64 r offset) 0))])] + [(_ integer-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) integer 16 8 #t)] + [(_ unsigned-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) unsigned 16 8 #t)] + [(_ integer-40 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) integer 32 8 #t)] + [(_ unsigned-40 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) unsigned 16 8 #t)] + [(_ integer-48 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) integer 32 16 #t)] + [(_ unsigned-48 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) unsigned 16 16 #t)] + [(_ integer-56 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) integer 32 16 8 #t)] + [(_ unsigned-56 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$swap-object-ref r offset) unsigned 32 16 8 #t)] [(_ type bytes pred) (#3%$swap-object-ref 'type r offset)])) (record-datatype cases (filter-foreign-type ty) ref ($oops who "unrecognized type ~s" ty)))) @@ -280,8 +443,9 @@ (set-who! $object-set! ; not safe, just handles non-constant types (lambda (ty r offset v) (define-syntax set - (syntax-rules (char wchar boolean integer-40 unsigned-40 integer-48 unsigned-48 - integer-56 unsigned-56 integer-64 unsigned-64) + (syntax-rules (char wchar boolean + integer-24 unsigned-24 integer-40 unsigned-40 integer-48 unsigned-48 + integer-56 unsigned-56 integer-64 unsigned-64) [(_ char bytes pred) (#3%$object-set! 'unsigned-8 r offset (char->integer v))] [(_ wchar bytes pred) @@ -292,88 +456,42 @@ (constant-case int-bits [(32) (#3%$object-set! 'integer-32 r offset (if v 1 0))] [(64) (#3%$object-set! 'integer-64 r offset (if v 1 0))])] + [(_ integer-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-set! r offset v) integer 16 8 #f)] + [(_ unsigned-24 bytes pred) + (eq? 'unknown (constant native-endianness)) + (build-multi-int (#3%$object-set! r offset v) unsigned 16 8 #f)] [(_ integer-40 bytes pred) - (< (constant ptr-bits) 64) - (begin - (constant-case native-endianness - [(big) - (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 8)) - (#3%$object-set! 'unsigned-8 r (fx+ offset 4) (logand v (- (expt 2 8) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'integer-8 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (build-multi-int (#3%$object-set! r offset v) integer 32 8 #f)] [(_ unsigned-40 bytes pred) - (< (constant ptr-bits) 64) - (begin - (constant-case native-endianness - [(big) - (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 8)) - (#3%$object-set! 'unsigned-8 r (fx+ offset 4) (logand v (- (expt 2 8) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'unsigned-8 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (build-multi-int (#3%$object-set! r offset v) unsigned 32 8 #f)] [(_ integer-48 bytes pred) - (< (constant ptr-bits) 64) - (begin - (constant-case native-endianness - [(big) - (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 16)) - (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand v (- (expt 2 16) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'integer-16 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (build-multi-int (#3%$object-set! r offset v) integer 32 16 #f)] [(_ unsigned-48 bytes pred) - (< (constant ptr-bits) 64) - (begin - (constant-case native-endianness - [(big) - (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 16)) - (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand v (- (expt 2 16) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (build-multi-int (#3%$object-set! r offset v) unsigned 32 16 #f)] [(_ integer-56 bytes pred) - (< (constant ptr-bits) 64) - (begin - (constant-case native-endianness - [(big) - (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 24)) - (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) - (#3%$object-set! 'unsigned-8 r (fx+ offset 6) (logand v (- (expt 2 8) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) - (#3%$object-set! 'integer-8 r (fx+ offset 6) (bitwise-arithmetic-shift-right v 48))]))] + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (build-multi-int (#3%$object-set! r offset v) integer 32 16 8 #f)] [(_ unsigned-56 bytes pred) - (< (constant ptr-bits) 64) - (begin - (constant-case native-endianness - [(big) - (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 24)) - (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) - (#3%$object-set! 'unsigned-8 r (fx+ offset 6) (logand v (- (expt 2 8) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) - (#3%$object-set! 'unsigned-8 r (fx+ offset 6) (bitwise-arithmetic-shift-right v 48))]))] + (or (< (constant ptr-bits) 64) + (eq? 'unknown (constant native-endianness))) + (build-multi-int (#3%$object-set! r offset v) unsigned 32 16 8 #f)] [(_ integer-64 bytes pred) (< (constant ptr-bits) 64) - (constant-case native-endianness - [(big) - (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 32)) - (#3%$object-set! 'unsigned-32 r (fx+ offset 4) (logand v (- (expt 2 32) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'integer-32 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))])] - [(_ unsigned-64 bytes pred) + (build-multi-int (#3%$object-set! r offset v) integer 32 32 #f)] + [(_ integer-64 bytes pred) (< (constant ptr-bits) 64) - (constant-case native-endianness - [(big) - (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 32)) - (#3%$object-set! 'unsigned-32 r (fx+ offset 4) (logand v (- (expt 2 32) 1)))] - [(little) - (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) - (#3%$object-set! 'unsigned-32 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))])] + (build-multi-int (#3%$object-set! r offset v) unsigned 32 32 #f)] [(_ type bytes pred) (#3%$object-set! 'type r offset v)])) (record-datatype cases (filter-foreign-type ty) set ($oops who "unrecognized type ~s" ty)))) diff --git a/workarea b/workarea index a79cd2472c..75a7dd2d51 100755 --- a/workarea +++ b/workarea @@ -15,9 +15,9 @@ # See the License for the specific language governing permissions and # limitations under the License. -if [ $# != 1 -a $# != 2 ] +if [ $# != 1 -a $# != 2 -a $# != 3 ] then - echo "Usage: workarea { }" + echo "Usage: workarea { }" exit 1 fi @@ -29,6 +29,14 @@ then else W=$2 fi +if [ "$3" != "" ] +then + Mpbhost=$3 +else + Mpbhost="" +fi + +Muni="" case "$M" in a6fb) ;; @@ -39,6 +47,7 @@ case "$M" in a6osx) ;; a6s2) ;; arm32le) ;; + arm64le) ;; i3fb) ;; i3le) ;; i3nb) ;; @@ -48,24 +57,25 @@ case "$M" in i3qnx) ;; i3s2) ;; ppc32le) ;; - ta6fb) ;; - ta6le) ;; - ta6nb) ;; - ta6nt) ;; - ta6ob) ;; - ta6osx) ;; - ta6s2) ;; - tarm32le) ;; - tarm64le) ;; - ti3fb) ;; - ti3le) ;; - ti3nb) ;; - ti3nt) ;; - ti3ob) ;; - ti3osx) ;; - ti3qnx) ;; - ti3s2) ;; - tppc32le) ;; + ta6fb) Muni=a6fb ;; + ta6le) Muni=a6le ;; + ta6nb) Muni=a6nb ;; + ta6nt) Muni=a6nt ;; + ta6ob) Muni=a6ob ;; + ta6osx) Muni=a6osx ;; + ta6s2) Muni=a6s2 ;; + tarm32le) Muni=arm32le ;; + tarm64le) Muni=arm64le ;; + ti3fb) Muni=i3fb ;; + ti3le) Muni=i3le ;; + ti3nb) Muni=i3nb ;; + ti3nt) Muni=i3nt ;; + ti3ob) Muni=i3ob ;; + ti3osx) Muni=i3osx ;; + ti3qnx) Muni=i3qnx ;; + ti3s2) Muni=i3s2 ;; + tppc32le) Muni=ppc32le ;; + pb) ;; *) echo "Unrecognized machine name $M"; exit 1 ;; esac @@ -127,6 +137,13 @@ workdir $W workdir $W/c (cd $W/c; workln ../../c/Mf-$M Mf-$M) (cd $W/c; forceworkln Mf-$M Makefile) +if [ "$Muni" != "" ] ; then + (cd $W/c; workln ../../c/Mf-$Muni Mf-$Muni) +fi +if [ "$Mpbhost" != "" ] ; then + (cd $W/c; workln ../../c/Mf-$Mpbhost Mf-$Mpbhost) + (cd $W/c; forceworkln Mf-$Mpbhost Mf-pbhost) +fi (cd $W/c; workln ../../c/Mf-base Mf-base) if [ ! -e $W/c/config.h ] ; then touch $W/c/config.h @@ -151,6 +168,13 @@ workdir $W/s workdir $W/mats (cd $W/mats; workln ../../mats/Mf-$M Mf-$M) (cd $W/mats; forceworkln Mf-$M Makefile) +if [ "$Muni" != "" ] ; then + (cd $W/mats; workln ../../mats/Mf-$Muni Mf-$Muni) +fi +if [ "$Mpbhost" != "" ] ; then + (cd $W/mats; workln ../../mats/Mf-$Mpbhost Mf-$Mpbhost) + (cd $W/mats; forceworkln Mf-$Mpbhost Mf-pbhost) +fi (cd $W/mats; workln ../../mats/Mf-base Mf-base) (cd $W/mats; workln ../../mats/Mf-exobj Mf-exobj) case $M in