From 6d328be69b66e97498b53a22937e1e674a2b11bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 18:13:25 -0500 Subject: [PATCH 01/45] all-fp-exceptions constant --- basis/math/floats/env/env.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 6a8110c4c1..91419c1fdf 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -18,6 +18,15 @@ UNION: fp-exception +fp-zero-divide+ +fp-inexact+ ; +CONSTANT: all-fp-exceptions + { + +fp-invalid-operation+ + +fp-overflow+ + +fp-underflow+ + +fp-zero-divide+ + +fp-inexact+ + } + SINGLETONS: +round-nearest+ +round-down+ From 6ce3c1d62c02e969e58e406d1a279c5254a454b8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 19:43:23 -0500 Subject: [PATCH 02/45] CFSTRING: syntax for defining CF/Cocoa string constants. update core-foundation.run-loop to use CFSTRING: --- basis/core-foundation/run-loop/run-loop.factor | 6 +----- basis/core-foundation/strings/strings.factor | 5 +++++ 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 6446eacd08..10d858a32f 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -54,11 +54,7 @@ FUNCTION: void CFRunLoopRemoveTimer ( CFStringRef mode ) ; -: CFRunLoopDefaultMode ( -- alien ) - #! Ugly, but we don't have static NSStrings - \ CFRunLoopDefaultMode [ - "kCFRunLoopDefaultMode" - ] initialize-alien ; +CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" TUPLE: run-loop fds sources timers ; diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 413709d142..45f4460d13 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -83,3 +83,8 @@ FUNCTION: CFStringRef CFStringCreateWithCString ( : ( seq -- alien ) [ [ &CFRelease ] map ] with-destructors ; + +SYNTAX: CFSTRING: + CREATE scan-object + [ drop ] [ '[ _ [ _ ] initialize-alien ] ] 2bi + (( -- alien )) define-declared ; From e70fa134b299cd934386785d548a686f85f91cee Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 19:43:57 -0500 Subject: [PATCH 03/45] add full complement of [SU]Int[0-9]+ typedefs to core-foundation --- basis/core-foundation/core-foundation.factor | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 63bfaf37ce..2ef388563e 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/basis/core-foundation/core-foundation.factor @@ -8,11 +8,16 @@ TYPEDEF: void* CFTypeRef TYPEDEF: void* CFAllocatorRef CONSTANT: kCFAllocatorDefault f -TYPEDEF: bool Boolean -TYPEDEF: long CFIndex -TYPEDEF: char UInt8 -TYPEDEF: int SInt32 -TYPEDEF: uint UInt32 +TYPEDEF: bool Boolean +TYPEDEF: long CFIndex +TYPEDEF: uchar UInt8 +TYPEDEF: ushort UInt16 +TYPEDEF: uint UInt32 +TYPEDEF: ulonglong UInt64 +TYPEDEF: char SInt8 +TYPEDEF: short SInt16 +TYPEDEF: int SInt32 +TYPEDEF: longlong SInt64 TYPEDEF: ulong CFTypeID TYPEDEF: UInt32 CFOptionFlags TYPEDEF: void* CFUUIDRef @@ -32,3 +37,4 @@ FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ; FUNCTION: void CFRelease ( CFTypeRef cf ) ; DESTRUCTOR: CFRelease + From 569db73858a1289c1c4c69d3a6f71bab2f2db2c0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 19:44:13 -0500 Subject: [PATCH 04/45] QTKit binding --- extra/qtkit/qtkit.factor | 76 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 extra/qtkit/qtkit.factor diff --git a/extra/qtkit/qtkit.factor b/extra/qtkit/qtkit.factor new file mode 100644 index 0000000000..d0567bdd48 --- /dev/null +++ b/extra/qtkit/qtkit.factor @@ -0,0 +1,76 @@ +USING: classes.struct cocoa core-foundation.strings ; +IN: qtkit + +STRUCT: QTTime + { timeValue longlong } + { timeScale long } + { flags long } ; + +STRUCT: QTTimeRange + { time QTTime } + { duration QTTime } ; + +STRUCT: SMPTETime + { mSubframes SInt16 } + { mSubframeDivisor SInt16 } + { mCounter UInt32 } + { mType UInt32 } + { mFlags UInt32 } + { mHours SInt16 } + { mMinutes SInt16 } + { mSeconds SInt16 } + { mFrames SInt16 } ; + +CFSTRING: QTKitErrorDomain "QTKitErrorDomain" +CFSTRING: QTErrorCaptureInputKey "QTErrorCaptureInputKey" +CFSTRING: QTErrorCaptureOutputKey "QTErrorCaptureOutputKey" +CFSTRING: QTErrorDeviceKey "QTErrorDeviceKey" +CFSTRING: QTErrorExcludingDeviceKey "QTErrorExcludingDeviceKey" +CFSTRING: QTErrorTimeKey "QTErrorTimeKey" +CFSTRING: QTErrorFileSizeKey "QTErrorFileSizeKey" +CFSTRING: QTErrorRecordingSuccesfullyFinishedKey "QTErrorRecordingSuccesfullyFinishedKey" + +CONSTANT: QTErrorUnknown -1 +CONSTANT: QTErrorIncompatibleInput 1002 +CONSTANT: QTErrorIncompatibleOutput 1003 +CONSTANT: QTErrorInvalidInputsOrOutputs 1100 +CONSTANT: QTErrorDeviceAlreadyUsedbyAnotherSession 1101 +CONSTANT: QTErrorNoDataCaptured 1200 +CONSTANT: QTErrorSessionConfigurationChanged 1201 +CONSTANT: QTErrorDiskFull 1202 +CONSTANT: QTErrorDeviceWasDisconnected 1203 +CONSTANT: QTErrorMediaChanged 1204 +CONSTANT: QTErrorMaximumDurationReached 1205 +CONSTANT: QTErrorMaximumFileSizeReached 1206 +CONSTANT: QTErrorMediaDiscontinuity 1207 +CONSTANT: QTErrorMaximumNumberOfSamplesForFileFormatReached 1208 +CONSTANT: QTErrorDeviceNotConnected 1300 +CONSTANT: QTErrorDeviceInUseByAnotherApplication 1301 +CONSTANT: QTErrorDeviceExcludedByAnotherDevice 1302 + +FRAMEWORK: /System/Library/Frameworks/QTKit.framework + +IMPORT: QTCaptureAudioPreviewOutput +IMPORT: QTCaptureConnection +IMPORT: QTCaptureDecompressedAudioOutput +IMPORT: QTCaptureDecompressedVideoOutput +IMPORT: QTCaptureDevice +IMPORT: QTCaptureDeviceInput +IMPORT: QTCaptureFileOutput +IMPORT: QTCaptureInput +IMPORT: QTCaptureLayer +IMPORT: QTCaptureMovieFileOutput +IMPORT: QTCaptureOutput +IMPORT: QTCaptureSession +IMPORT: QTCaptureVideoPreviewOutput +IMPORT: QTCaptureView +IMPORT: QTCompressionOptions +IMPORT: QTDataReference +IMPORT: QTFormatDescription +IMPORT: QTMedia +IMPORT: QTMovie +IMPORT: QTMovieLayer +IMPORT: QTMovieView +IMPORT: QTSampleBuffer +IMPORT: QTTrack + From 53e23de104e92edceb300c7bdec4ca920b6dfd42 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 12 Sep 2009 20:39:41 -0500 Subject: [PATCH 05/45] set altivec denormal flag when with-denormal-mode is used --- basis/math/floats/env/ppc/ppc.factor | 42 +++++++++++++++++++++++++++- vm/Config.macosx.ppc | 2 +- vm/cpu-ppc.S | 23 +++++++++++++++ 3 files changed, 65 insertions(+), 2 deletions(-) diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index c4c81471ca..748f149ccd 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -7,19 +7,32 @@ STRUCT: ppc-fpu-env { padding uint } { fpscr uint } ; +STRUCT: ppc-vmx-env + { vscr uint } ; + ! defined in the vm, cpu-ppc*.S FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ; FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ; +FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ; +FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ; + : ( -- ppc-fpu-env ) ppc-fpu-env (struct) [ get_ppc_fpu_env ] keep ; +: ( -- ppc-fpu-env ) + ppc-vmx-env (struct) + [ get_ppc_vmx_env ] keep ; + M: ppc-fpu-env (set-fp-env-register) set_ppc_fpu_env ; +M: ppc-vmx-env (set-fp-env-register) + set_ppc_vmx_env ; + M: ppc (fp-env-registers) - 1array ; + 2array ; CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000 CONSTANT: ppc-exception-flag>bit @@ -77,3 +90,30 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' ) } case ] curry change-fpscr ; inline +CONSTANT: vmx-denormal-mode-bits HEX: 8000 + +M: ppc-vmx-env (get-exception-flags) ( register -- exceptions ) + drop { } ; inline +M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' ) + drop ; + +M: ppc-vmx-env (get-fp-traps) ( register -- exceptions ) + drop { } ; inline +M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' ) + drop ; + +M: ppc-vmx-env (get-rounding-mode) ( register -- mode ) + drop +round-nearest+ ; +M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' ) + drop ; + +M: ppc-vmx-env (get-denormal-mode) ( register -- mode ) + vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline +M: ppc-vmx-env (get-denormal-mode) ( register mode -- register ) + [ + { + { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] } + { +denormal-flush+ [ vmx-denormal-mode-bits bitor ] } + } case + ] curry change-vscr ; inline + diff --git a/vm/Config.macosx.ppc b/vm/Config.macosx.ppc index ed3c0d5a19..9fb84d6185 100644 --- a/vm/Config.macosx.ppc +++ b/vm/Config.macosx.ppc @@ -1,3 +1,3 @@ include vm/Config.macosx include vm/Config.ppc -CFLAGS += -arch ppc +CFLAGS += -arch ppc -force_cpusubtype_ALL diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 67c9e8d142..007638189a 100644 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -254,3 +254,26 @@ DEF(void,set_ppc_fpu_env,(const void*)): lfd f0,0(r3) mtfsf 0xff,f0 blr + +DEF(void,get_ppc_vmx_env,(void*)): + mfvscr v0 + subi r4,r1,16 + li r5,0xf + andc r4,r4,r5 + li r5,0xc + stvewx v0,r5,r4 + lwzx r6,r5,r4 + stw r6,0(r3) + blr + +DEF(void,set_ppc_vmx_env,(const void*)): + subi r4,r1,16 + li r5,0xf + andc r4,r4,r5 + li r5,0xc + lwz r6,0(r3) + stwx r6,r5,r4 + lvewx v0,r5,r4 + mtvscr v0 + blr + From 32b95c2cdfda7b9e7139127e4f8c78199bf80b58 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Sep 2009 22:20:13 -0500 Subject: [PATCH 06/45] math: add unordered comparison operators u< u<= u> u>= which behave exactly like < <= > >= except no floating point exceptions are set if one or both inputs are NaNs; also add efficient intrinsic for unordered? predicate, and fix propagation type functions for abs, absq, and bitnot --- .../cfg/intrinsics/float/float.factor | 5 +- .../compiler/cfg/intrinsics/intrinsics.factor | 15 +- basis/compiler/tests/float.factor | 12 ++ .../tree/comparisons/comparisons.factor | 36 +++-- .../known-words/known-words.factor | 56 ++++---- .../tree/propagation/propagation-tests.factor | 65 +++++++++ basis/math/floats/env/env-tests.factor | 130 ++++++++++++------ basis/math/floats/env/env.factor | 2 +- .../partial-dispatch/partial-dispatch.factor | 6 + .../known-words/known-words.factor | 18 ++- core/bootstrap/primitives.factor | 4 + core/math/floats/floats-docs.factor | 79 +++++++++-- core/math/floats/floats.factor | 13 +- core/math/integers/integers.factor | 10 ++ core/math/math-docs.factor | 43 +++++- core/math/math.factor | 7 +- vm/primitives.cpp | 6 + 17 files changed, 396 insertions(+), 111 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/float/float.factor b/basis/compiler/cfg/intrinsics/float/float.factor index 8dab157f4e..8a65de5805 100644 --- a/basis/compiler/cfg/intrinsics/float/float.factor +++ b/basis/compiler/cfg/intrinsics/float/float.factor @@ -7,7 +7,10 @@ IN: compiler.cfg.intrinsics.float : emit-float-op ( insn -- ) [ 2inputs ] dip call ds-push ; inline -: emit-float-comparison ( cc -- ) +: emit-float-ordered-comparison ( cc -- ) + [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline + +: emit-float-unordered-comparison ( cc -- ) [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline : emit-float>fixnum ( -- ) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index ec567558bd..a54caf23de 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -86,13 +86,18 @@ IN: compiler.cfg.intrinsics { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] } { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] } { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] } - { math.private:float< [ drop cc< emit-float-comparison ] } - { math.private:float<= [ drop cc<= emit-float-comparison ] } - { math.private:float>= [ drop cc>= emit-float-comparison ] } - { math.private:float> [ drop cc> emit-float-comparison ] } - { math.private:float= [ drop cc= emit-float-comparison ] } + { math.private:float< [ drop cc< emit-float-ordered-comparison ] } + { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] } + { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] } + { math.private:float> [ drop cc> emit-float-ordered-comparison ] } + { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] } + { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] } + { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] } + { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] } + { math.private:float= [ drop cc= emit-float-unordered-comparison ] } { math.private:float>fixnum [ drop emit-float>fixnum ] } { math.private:fixnum>float [ drop emit-fixnum>float ] } + { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] } { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] } { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] } { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] } diff --git a/basis/compiler/tests/float.factor b/basis/compiler/tests/float.factor index 86d7899fab..14b347008c 100644 --- a/basis/compiler/tests/float.factor +++ b/basis/compiler/tests/float.factor @@ -88,3 +88,15 @@ IN: compiler.tests.float [ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test [ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test [ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test + +[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test +[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test +[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test +[ f ] [ 3.0 1.0 [ float-unordered? ] compile-call ] unit-test +[ f ] [ 1.0 3.0 [ float-unordered? ] compile-call ] unit-test + +[ 1 ] [ 0/0. 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 ] [ 0/0. 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test diff --git a/basis/compiler/tree/comparisons/comparisons.factor b/basis/compiler/tree/comparisons/comparisons.factor index 5f4b1e8dab..b8e79e33ca 100644 --- a/basis/compiler/tree/comparisons/comparisons.factor +++ b/basis/compiler/tree/comparisons/comparisons.factor @@ -1,28 +1,36 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: math math.order math.intervals assocs combinators ; IN: compiler.tree.comparisons ! Some utilities for working with comparison operations. -CONSTANT: comparison-ops { < > <= >= } +CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= } CONSTANT: generic-comparison-ops { before? after? before=? after=? } : assumption ( i1 i2 op -- i3 ) { - { \ < [ assume< ] } - { \ > [ assume> ] } - { \ <= [ assume<= ] } - { \ >= [ assume>= ] } + { \ < [ assume< ] } + { \ > [ assume> ] } + { \ <= [ assume<= ] } + { \ >= [ assume>= ] } + { \ u< [ assume< ] } + { \ u> [ assume> ] } + { \ u<= [ assume<= ] } + { \ u>= [ assume>= ] } } case ; : interval-comparison ( i1 i2 op -- result ) { - { \ < [ interval< ] } - { \ > [ interval> ] } - { \ <= [ interval<= ] } - { \ >= [ interval>= ] } + { \ < [ interval< ] } + { \ > [ interval> ] } + { \ <= [ interval<= ] } + { \ >= [ interval>= ] } + { \ u< [ interval< ] } + { \ u> [ interval> ] } + { \ u<= [ interval<= ] } + { \ u>= [ interval>= ] } } case ; : swap-comparison ( op -- op' ) @@ -31,6 +39,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? } { > < } { <= >= } { >= <= } + { u< u> } + { u> u< } + { u<= u>= } + { u>= u<= } } at ; : negate-comparison ( op -- op' ) @@ -39,6 +51,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? } { > <= } { <= > } { >= < } + { u< u>= } + { u> u<= } + { u<= u> } + { u>= u< } } at ; : specific-comparison ( op -- op' ) diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 5fe7d5ee1b..63d2df543d 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -23,7 +23,7 @@ IN: compiler.tree.propagation.known-words { + - * / } [ { number number } "input-classes" set-word-prop ] each -{ /f < > <= >= } +{ /f < > <= >= u< u> u<= u>= } [ { real real } "input-classes" set-word-prop ] each { /i mod /mod } @@ -34,21 +34,6 @@ IN: compiler.tree.propagation.known-words \ bitnot { integer } "input-classes" set-word-prop -: real-op ( info quot -- quot' ) - [ - dup class>> real classes-intersect? - [ clone ] [ drop real ] if - ] dip - change-interval ; inline - -{ bitnot fixnum-bitnot bignum-bitnot } [ - [ [ interval-bitnot ] real-op ] "outputs" set-word-prop -] each - -\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop - -\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop - : math-closure ( class -- newclass ) { fixnum bignum integer rational float real number object } [ class<= ] with find nip ; @@ -56,15 +41,6 @@ IN: compiler.tree.propagation.known-words : fits-in-fixnum? ( interval -- ? ) fixnum-interval interval-subset? ; -: binary-op-class ( info1 info2 -- newclass ) - [ class>> ] bi@ - 2dup [ null-class? ] either? [ 2drop null ] [ - [ math-closure ] bi@ math-class-max - ] if ; - -: binary-op-interval ( info1 info2 quot -- newinterval ) - [ [ interval>> ] bi@ ] dip call ; inline - : won't-overflow? ( class interval -- ? ) [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ; @@ -101,6 +77,36 @@ IN: compiler.tree.propagation.known-words [ drop float ] dip ] unless ; +: unary-op-class ( info -- newclass ) + class>> dup null-class? [ drop null ] [ math-closure ] if ; + +: unary-op-interval ( info quot -- newinterval ) + [ interval>> ] dip call ; inline + +: unary-op ( word interval-quot post-proc-quot -- ) + '[ + [ unary-op-class ] [ _ unary-op-interval ] bi + @ + + ] "outputs" set-word-prop ; + +{ bitnot fixnum-bitnot bignum-bitnot } [ + [ interval-bitnot ] [ integer-valued ] unary-op +] each + +\ abs [ interval-abs ] [ may-overflow real-valued ] unary-op + +\ absq [ interval-absq ] [ may-overflow real-valued ] unary-op + +: binary-op-class ( info1 info2 -- newclass ) + [ class>> ] bi@ + 2dup [ null-class? ] either? [ 2drop null ] [ + [ math-closure ] bi@ math-class-max + ] if ; + +: binary-op-interval ( info1 info2 quot -- newinterval ) + [ [ interval>> ] bi@ ] dip call ; inline + : binary-op ( word interval-quot post-proc-quot -- ) '[ [ binary-op-class ] [ _ binary-op-interval ] 2bi diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 1b24bc0c8f..ec5fbd95cd 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -31,6 +31,8 @@ IN: compiler.tree.propagation.tests [ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test +[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test ! Test type propagation for math ops @@ -164,6 +166,18 @@ IN: compiler.tree.propagation.tests [ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test +[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test + +[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test + +[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test + +[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test + [ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test [ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test @@ -247,6 +261,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + [ V{ 1.5 } ] [ [ /f @@ -254,6 +275,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ 1.5 } ] [ + [ + /f + dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if + ] final-literals +] unit-test + [ V{ f } ] [ [ /f @@ -261,6 +289,13 @@ IN: compiler.tree.propagation.tests ] final-literals ] unit-test +[ V{ f } ] [ + [ + /f + dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if + ] final-literals +] unit-test + [ V{ fixnum } ] [ [ 0 dup 10 > [ 100 * ] when ] final-classes ] unit-test @@ -269,6 +304,14 @@ IN: compiler.tree.propagation.tests [ 0 dup 10 > [ drop "foo" ] when ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ 0 dup 10 u> [ 100 * ] when ] final-classes +] unit-test + +[ V{ fixnum } ] [ + [ 0 dup 10 u> [ drop "foo" ] when ] final-classes +] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare 3 3 - + ] final-classes ] unit-test @@ -277,6 +320,10 @@ IN: compiler.tree.propagation.tests [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals ] unit-test +[ V{ t } ] [ + [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals +] unit-test + [ V{ "d" } ] [ [ 3 { @@ -300,10 +347,18 @@ IN: compiler.tree.propagation.tests [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes ] unit-test +[ V{ fixnum } ] [ + [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes +] unit-test + [ V{ -1 } ] [ [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals ] unit-test +[ V{ -1 } ] [ + [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals +] unit-test + [ V{ 2 } ] [ [ [ 1 ] [ 1 ] if 1 + ] final-literals ] unit-test @@ -312,12 +367,22 @@ IN: compiler.tree.propagation.tests [ 0 * 10 < ] final-classes ] unit-test +[ V{ object } ] [ + [ 0 * 10 u< ] final-classes +] unit-test + [ V{ 27 } ] [ [ 123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if ] final-literals ] unit-test +[ V{ 27 } ] [ + [ + 123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if + ] final-literals +] unit-test + [ V{ 27 } ] [ [ dup number? over sequence? and [ diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index a0ffa0713c..0c38d69ea9 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,5 +1,6 @@ USING: kernel math math.floats.env math.floats.env.private -math.functions math.libm sequences tools.test ; +math.functions math.libm sequences tools.test locals +compiler.units kernel.private fry compiler math.private words ; IN: math.floats.env.tests : set-default-fp-env ( -- ) @@ -8,45 +9,29 @@ IN: math.floats.env.tests ! In case the tests screw up the FP env because of bugs in math.floats.env set-default-fp-env -[ t ] [ - [ 1.0 0.0 / drop ] collect-fp-exceptions - +fp-zero-divide+ swap member? -] unit-test +: test-fp-exception ( exception inputs quot -- quot' ) + '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ; -[ t ] [ - [ 1.0 3.0 / drop ] collect-fp-exceptions - +fp-inexact+ swap member? -] unit-test +: test-fp-exception-compiled ( exception inputs quot -- quot' ) + '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ; -[ t ] [ - [ 1.0e250 1.0e100 * drop ] collect-fp-exceptions - +fp-overflow+ swap member? -] unit-test +[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test +[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test +[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test +[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test +[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test +[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test -[ t ] [ - [ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions - +fp-underflow+ swap member? -] unit-test - -[ t ] [ - [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions - +fp-overflow+ swap member? -] unit-test - -[ t ] [ - [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions - +fp-underflow+ swap member? -] unit-test - -[ t ] [ - [ 0.0 0.0 /f drop ] collect-fp-exceptions - +fp-invalid-operation+ swap member? -] unit-test - -[ t ] [ - [ -1.0 fsqrt drop ] collect-fp-exceptions - +fp-invalid-operation+ swap member? -] unit-test +[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test +[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test +[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test +[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test +[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test +[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test [ HEX: 3fd5,5555,5555,5555 @@ -117,11 +102,72 @@ set-default-fp-env -1.0 3.0 /f double>bits ] unit-test -[ { +fp-zero-divide+ } [ 1.0 0.0 /f ] with-fp-traps ] must-fail -[ { +fp-inexact+ } [ 1.0 3.0 /f ] with-fp-traps ] must-fail -[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail -[ { +fp-overflow+ } [ 2.0 100,000.0 ^ ] with-fp-traps ] must-fail -[ { +fp-underflow+ } [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail +: test-traps ( traps inputs quot -- quot' ) + append '[ _ _ with-fp-traps ] ; + +: test-traps-compiled ( traps inputs quot -- quot' ) + swapd '[ _ [ _ _ with-fp-traps ] compile-call ] ; + +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail +{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail +{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail + +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail +{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail + +! Ensure ordered comparisons raise traps +:: test-comparison-quot ( word -- quot ) + [ + { float float } declare + { +fp-invalid-operation+ } [ word execute ] with-fp-traps + ] ; + +: test-comparison ( inputs word -- quot ) + test-comparison-quot append ; + +: test-comparison-compiled ( inputs word -- quot ) + test-comparison-quot '[ @ _ compile-call ] ; + +\ float< "intrinsic" word-prop [ + [ 0/0. -15.0 ] \ < test-comparison must-fail + [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail + [ -15.0 0/0. ] \ < test-comparison must-fail + [ -15.0 0/0. ] \ < test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ <= test-comparison must-fail + [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ <= test-comparison must-fail + [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ > test-comparison must-fail + [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail + [ -15.0 0/0. ] \ > test-comparison must-fail + [ -15.0 0/0. ] \ > test-comparison-compiled must-fail + [ 0/0. -15.0 ] \ >= test-comparison must-fail + [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail + [ -15.0 0/0. ] \ >= test-comparison must-fail + [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail + + [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test + [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test + [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test +] when ! Ensure traps get cleared [ 1/0. ] [ 1.0 0.0 /f ] unit-test diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 6a8110c4c1..ba198168da 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -102,7 +102,7 @@ PRIVATE> : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline : collect-fp-exceptions ( quot -- exceptions ) - clear-fp-exception-flags call fp-exception-flags ; inline + [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ; diff --git a/basis/math/partial-dispatch/partial-dispatch.factor b/basis/math/partial-dispatch/partial-dispatch.factor index 6679e81fcd..7c66c911de 100644 --- a/basis/math/partial-dispatch/partial-dispatch.factor +++ b/basis/math/partial-dispatch/partial-dispatch.factor @@ -197,6 +197,12 @@ SYMBOL: fast-math-ops \ <= define-math-ops \ > define-math-ops \ >= define-math-ops + + \ u< define-math-ops + \ u<= define-math-ops + \ u> define-math-ops + \ u>= define-math-ops + \ number= define-math-ops { { shift bignum bignum } bignum-shift } , diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ea8f6f5f49..0de957b785 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -455,12 +455,12 @@ M: bad-executable summary \ float/f { float float } { float } define-primitive \ float/f make-foldable -\ float< { float float } { object } define-primitive -\ float< make-foldable - \ float-mod { float float } { float } define-primitive \ float-mod make-foldable +\ float< { float float } { object } define-primitive +\ float< make-foldable + \ float<= { float float } { object } define-primitive \ float<= make-foldable @@ -470,6 +470,18 @@ M: bad-executable summary \ float>= { float float } { object } define-primitive \ float>= make-foldable +\ float-u< { float float } { object } define-primitive +\ float-u< make-foldable + +\ float-u<= { float float } { object } define-primitive +\ float-u<= make-foldable + +\ float-u> { float float } { object } define-primitive +\ float-u> make-foldable + +\ float-u>= { float float } { object } define-primitive +\ float-u>= make-foldable + \ { object object } { word } define-primitive \ make-flushable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 13e17f90fd..355fa8ed58 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -409,6 +409,10 @@ tuple { "float<=" "math.private" (( x y -- ? )) } { "float>" "math.private" (( x y -- ? )) } { "float>=" "math.private" (( x y -- ? )) } + { "float-u<" "math.private" (( x y -- ? )) } + { "float-u<=" "math.private" (( x y -- ? )) } + { "float-u>" "math.private" (( x y -- ? )) } + { "float-u>=" "math.private" (( x y -- ? )) } { "" "words" (( name vocab -- word )) } { "word-xt" "words" (( word -- start end )) } { "getenv" "kernel.private" (( n -- obj )) } diff --git a/core/math/floats/floats-docs.factor b/core/math/floats/floats-docs.factor index ed4947e1f5..6e903a37e2 100644 --- a/core/math/floats/floats-docs.factor +++ b/core/math/floats/floats-docs.factor @@ -69,20 +69,54 @@ HELP: float> ( x y -- ? ) HELP: float>= ( x y -- ? ) { $values { "x" float } { "y" float } { "?" "a boolean" } } -{ $description "Primitive version of " { $link >= } "." } -{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ; +{ $description "Primitive version of " { $link u>= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ; -ARTICLE: "floats" "Floats" -{ $subsection float } -"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums." +HELP: float-u< ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u< } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u< } " instead." } ; + +HELP: float-u<= ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u<= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u<= } " instead." } ; + +HELP: float-u> ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u> } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u> } " instead." } ; + +HELP: float-u>= ( x y -- ? ) +{ $values { "x" float } { "y" float } { "?" "a boolean" } } +{ $description "Primitive version of " { $link u>= } "." } +{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ; + +ARTICLE: "math.floats.compare" "Floating point comparison operations" +"In mathematics, real numbers are linearly ordered; for any two numbers " { $snippet "a" } " and " { $snippet "b" } ", exactly one of the following is true:" +{ $code + "a < b" + "a = b" + "a > b" +} +"With floating point values, there is a fourth possibility; " { $snippet "a" } " and " { $snippet "b" } " may be " { $emphasis "unordered" } ". This happens if one or both values are Not-a-Number values." $nl -"Introducing a floating point number in a computation forces the result to be expressed in floating point." -{ $example "5/4 1/2 + ." "1+3/4" } -{ $example "5/4 0.5 + ." "1.75" } -"Integers and rationals can be converted to floats:" -{ $subsection >float } -"Two real numbers can be divided yielding a float result:" -{ $subsection /f } +"All comparison operators, including " { $link number= } ", return " { $link f } " in the unordered case (and in particular, this means that a NaN is not equal to itself)." +$nl +"The " { $emphasis "ordered" } " comparison operators set floating point exception flags if the result of the comparison is unordered. The standard comparison operators (" { $link < } ", " { $link <= } ", " { $link > } ", " { $link >= } ") perform ordered comparisons." +$nl +"The " { $link number= } " operation performs an unordered comparison. The following set of operators also perform unordered comparisons:" +{ $subsection u< } +{ $subsection u<= } +{ $subsection u> } +{ $subsection u>= } +"A word to check if two values are unordered with respect to each other:" +{ $subsection unordered? } +"To test for floating point exceptions, use the " { $vocab-link "math.floats.env" } " vocabulary." +$nl +"If neither input to a comparison operator is a floating point value, then " { $link u< } ", " { $link u<= } ", " { $link u> } " and " { $link u>= } " are equivalent to the ordered operators." ; + +ARTICLE: "math.floats.bitwise" "Bitwise operations on floats" "Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes." { $subsection float>bits } { $subsection double>bits } @@ -100,8 +134,25 @@ $nl { $subsection fp-snan? } { $subsection fp-infinity? } { $subsection fp-nan-payload } -"Comparing two floating point numbers:" +"Comparing two floating point numbers for bitwise equality:" { $subsection fp-bitwise= } -{ $see-also "syntax-floats" } ; +{ $see-also POSTPONE: NAN: } ; + +ARTICLE: "floats" "Floats" +{ $subsection float } +"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums." +$nl +"Introducing a floating point number in a computation forces the result to be expressed in floating point." +{ $example "5/4 1/2 + ." "1+3/4" } +{ $example "5/4 0.5 + ." "1.75" } +"Floating point literal syntax is documented in " { $link "syntax-floats" } "." +$nl +"Integers and rationals can be converted to floats:" +{ $subsection >float } +"Two real numbers can be divided yielding a float result:" +{ $subsection /f } +{ $subsection "math.floats.bitwise" } +{ $subsection "math.floats.compare" } +"The " { $vocab-link "math.floats.env" } " vocabulary provides functionality for controlling floating point exceptions, rounding modes, and denormal behavior." ; ABOUT: "floats" diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 9c49e99231..bc419b94c5 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -3,6 +3,7 @@ USING: kernel math math.private ; IN: math.floats.private +: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ; : float-min ( x y -- z ) [ float< ] most ; foldable : float-max ( x y -- z ) [ float> ] most ; foldable @@ -17,11 +18,17 @@ M: float hashcode* nip float>bits ; inline M: float equal? over float? [ float= ] [ 2drop f ] if ; inline M: float number= float= ; inline -M: float < float< ; inline +M: float < float< ; inline M: float <= float<= ; inline -M: float > float> ; inline +M: float > float> ; inline M: float >= float>= ; inline +M: float unordered? float-unordered? ; inline +M: float u< float-u< ; inline +M: float u<= float-u<= ; inline +M: float u> float-u> ; inline +M: float u>= float-u>= ; inline + M: float + float+ ; inline M: float - float- ; inline M: float * float* ; inline @@ -58,8 +65,6 @@ M: float next-float ] if ] if ; inline -M: float unordered? [ fp-nan? ] bi@ or ; inline - M: float prev-float double>bits dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index ed25e3bfa6..e684b8edfb 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -24,6 +24,11 @@ M: fixnum <= fixnum<= ; inline M: fixnum > fixnum> ; inline M: fixnum >= fixnum>= ; inline +M: fixnum u< fixnum< ; inline +M: fixnum u<= fixnum<= ; inline +M: fixnum u> fixnum> ; inline +M: fixnum u>= fixnum>= ; inline + M: fixnum + fixnum+ ; inline M: fixnum - fixnum- ; inline M: fixnum * fixnum* ; inline @@ -65,6 +70,11 @@ M: bignum <= bignum<= ; inline M: bignum > bignum> ; inline M: bignum >= bignum>= ; inline +M: bignum u< bignum< ; inline +M: bignum u<= bignum<= ; inline +M: bignum u> bignum> ; inline +M: bignum u>= bignum>= ; inline + M: bignum + bignum+ ; inline M: bignum - bignum- ; inline M: bignum * bignum* ; inline diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 97e0a1e7cf..e5de106bbb 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -5,7 +5,9 @@ IN: math HELP: number= { $values { "x" number } { "y" number } { "?" "a boolean" } } { $description "Tests if two numbers have the same numeric value." } -{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." } +{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." +$nl +"This word performs an unordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } { $examples { $example "USING: math prettyprint ;" "3.0 3 number= ." "t" } { $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" } @@ -13,20 +15,47 @@ HELP: number= HELP: < { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: <= { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: > { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; HELP: >= { $values { "x" real } { "y" real } { "?" boolean } } -{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ; +{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ; +HELP: unordered? +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is unordered with respect to " { $snippet "y" } ". This can only occur if one or both values is a floating-point Not-a-Number value." } ; + +HELP: u< +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link < } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u<= +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link <= } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u> +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link > } ". See " { $link "math.floats.compare" } " for an explanation." } ; + +HELP: u>= +{ $values { "x" real } { "y" real } { "?" boolean } } +{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } +{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link >= } ". See " { $link "math.floats.compare" } " for an explanation." } ; HELP: + { $values { "x" number } { "y" number } { "z" number } } @@ -328,6 +357,10 @@ HELP: fp-infinity? { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" } } ; +HELP: fp-sign +{ $values { "x" float } { "?" "a boolean" } } +{ $description "Outputs the sign bit of " { $snippet "x" } ". For ordered non-zero values, this is equivalent to calling " { $snippet "0 <" } ". For zero values, this outputs the zero's sign bit." } ; + HELP: fp-nan-payload { $values { "x" real } { "bits" integer } } { $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ; diff --git a/core/math/math.factor b/core/math/math.factor index 900c1e1cee..8ef4f38f9a 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private ; IN: math @@ -22,7 +22,12 @@ MATH: < ( x y -- ? ) foldable MATH: <= ( x y -- ? ) foldable MATH: > ( x y -- ? ) foldable MATH: >= ( x y -- ? ) foldable + MATH: unordered? ( x y -- ? ) foldable +MATH: u< ( x y -- ? ) foldable +MATH: u<= ( x y -- ? ) foldable +MATH: u> ( x y -- ? ) foldable +MATH: u>= ( x y -- ? ) foldable M: object unordered? 2drop f ; diff --git a/vm/primitives.cpp b/vm/primitives.cpp index 2359173d9b..6dbe281d0c 100644 --- a/vm/primitives.cpp +++ b/vm/primitives.cpp @@ -51,6 +51,12 @@ const primitive_type primitives[] = { primitive_float_lesseq, primitive_float_greater, primitive_float_greatereq, + /* The unordered comparison primitives don't have a non-optimizing + compiler implementation */ + primitive_float_less, + primitive_float_lesseq, + primitive_float_greater, + primitive_float_greatereq, primitive_word, primitive_word_xt, primitive_getenv, From 3a61107f1dab168787a4ae41b9297022dba97810 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 12 Sep 2009 22:30:11 -0500 Subject: [PATCH 07/45] typos in altivec env --- basis/math/floats/env/ppc/ppc.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index 748f149ccd..4ce3f0512e 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -90,7 +90,7 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' ) } case ] curry change-fpscr ; inline -CONSTANT: vmx-denormal-mode-bits HEX: 8000 +CONSTANT: vmx-denormal-mode-bits HEX: 10000 M: ppc-vmx-env (get-exception-flags) ( register -- exceptions ) drop { } ; inline @@ -109,7 +109,7 @@ M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' ) M: ppc-vmx-env (get-denormal-mode) ( register -- mode ) vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline -M: ppc-vmx-env (get-denormal-mode) ( register mode -- register ) +M: ppc-vmx-env (set-denormal-mode) ( register mode -- register ) [ { { +denormal-keep+ [ vmx-denormal-mode-bits unmask ] } From 7b36689416819ca0bc290f5b0fa5341e7cc78c41 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:17:24 -0500 Subject: [PATCH 08/45] core-foundation.strings: fix load error --- basis/core-foundation/strings/strings.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 45f4460d13..4bbe050230 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien.syntax alien.strings io.encodings.string kernel sequences byte-arrays io.encodings.utf8 math core-foundation -core-foundation.arrays destructors ; +core-foundation.arrays destructors parser fry alien words ; IN: core-foundation.strings TYPEDEF: void* CFStringRef From 4686063d0fe65a03d69f07e1b0d8b26b60aa3641 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:17:45 -0500 Subject: [PATCH 09/45] qtkit: add tags and authors --- extra/qtkit/authors.txt | 1 + extra/qtkit/tags.txt | 1 + 2 files changed, 2 insertions(+) create mode 100644 extra/qtkit/authors.txt create mode 100644 extra/qtkit/tags.txt diff --git a/extra/qtkit/authors.txt b/extra/qtkit/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/qtkit/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/qtkit/tags.txt b/extra/qtkit/tags.txt new file mode 100644 index 0000000000..6bf68304bb --- /dev/null +++ b/extra/qtkit/tags.txt @@ -0,0 +1 @@ +unportable From 4f094a7ce52c40a70061722a33d452d2c6cb57d8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 13 Sep 2009 00:21:57 -0500 Subject: [PATCH 10/45] fix bootstrap on openbsd --- basis/io/files/info/unix/openbsd/openbsd.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/files/info/unix/openbsd/openbsd.factor b/basis/io/files/info/unix/openbsd/openbsd.factor index fe94f70fd8..be88929f2e 100755 --- a/basis/io/files/info/unix/openbsd/openbsd.factor +++ b/basis/io/files/info/unix/openbsd/openbsd.factor @@ -6,7 +6,7 @@ sequences system unix unix.getfsstat.openbsd grouping unix.statfs.openbsd unix.statvfs.openbsd unix.types arrays io.files.info.unix classes.struct specialized-arrays io.encodings.utf8 ; -SPECIALIZED-ARRAY: statvfs +SPECIALIZED-ARRAY: statfs IN: io.files.unix.openbsd TUPLE: openbsd-file-system-info < unix-file-system-info From 16209bf68d1e38109ed403f7212e0b7dbf5bcb48 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:24:31 -0500 Subject: [PATCH 11/45] specialized-arrays: fix unit tests now that ALIEN: expects a hex literal --- basis/specialized-arrays/specialized-arrays-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index ebc21eec56..2698149bac 100755 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -100,12 +100,12 @@ SPECIALIZED-ARRAY: test-struct ] unit-test ! Regression -STRUCT: fixed-string { text char[100] } ; +STRUCT: fixed-string { text char[64] } ; SPECIALIZED-ARRAY: fixed-string -[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [ - ALIEN: 123 4 [ (underlying)>> ] { } map-as +[ { ALIEN: 100 ALIEN: 140 ALIEN: 180 ALIEN: 1c0 } ] [ + ALIEN: 100 4 [ (underlying)>> ] { } map-as ] unit-test ! Ensure that byte-length works with direct arrays From 0d4845de2678121c81c3082884acfc2610925256 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 00:54:04 -0500 Subject: [PATCH 12/45] benchmark.gc1: reduce memory usage --- extra/benchmark/gc1/gc1.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/benchmark/gc1/gc1.factor b/extra/benchmark/gc1/gc1.factor index 8b0a3e6a43..da3b6bab66 100644 --- a/extra/benchmark/gc1/gc1.factor +++ b/extra/benchmark/gc1/gc1.factor @@ -3,6 +3,6 @@ USING: math sequences kernel ; IN: benchmark.gc1 -: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ; +: gc1 ( -- ) 10 [ 600000 [ >bignum 1 + ] map drop ] times ; MAIN: gc1 From b469dc29fab54a1f6f489b167886383633877600 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 13 Sep 2009 13:18:24 -0500 Subject: [PATCH 13/45] save vector registers, save control register, and enable denormals before calling factor in powerpc c_to_factor() --- vm/cpu-ppc.S | 58 +++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 55 insertions(+), 3 deletions(-) diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 007638189a..342ec83d7e 100644 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -63,7 +63,9 @@ multiply_overflow: #define SAVED_FP_REGS_SIZE 144 -#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8) +#define SAVED_V_REGS_SIZE 208 + +#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + SAVED_V_REGS_SIZE + 8) #if defined( __APPLE__) #define LR_SAVE 8 @@ -85,6 +87,13 @@ multiply_overflow: #define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1) #define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1) +#define SAVE_V(register,offset) \ + li r2,SAVE_AT(offset) XX \ + stvxl register,r2,r1 +#define RESTORE_V(register,offset) \ + li r2,SAVE_AT(offset) XX \ + lvxl register,r2,r1 + #define PROLOGUE \ mflr r0 XX /* get caller's return address */ \ stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \ @@ -95,6 +104,8 @@ multiply_overflow: lwz r1,0(r1) XX /* destroy the stack frame */ \ mtlr r0 /* get ready to return */ + + /* We have to save and restore nonvolatile registers because the Factor compiler treats the entire register file as volatile. */ DEF(void,c_to_factor,(CELL quot)): @@ -137,6 +148,31 @@ DEF(void,c_to_factor,(CELL quot)): SAVE_FP(f30,52) SAVE_FP(f31,54) + SAVE_V(v20,56) + SAVE_V(v21,60) + SAVE_V(v22,64) + SAVE_V(v23,68) + SAVE_V(v24,72) + SAVE_V(v25,76) + SAVE_V(v26,80) + SAVE_V(v27,84) + SAVE_V(v28,88) + SAVE_V(v29,92) + SAVE_V(v30,96) + SAVE_V(v31,100) + + mfvscr v0 + li r2,SAVE_AT(104) + stvxl v0,r2,r1 + addi r2,r2,0xc + lwzx r4,r2,r1 + lis r5,0x1 + andc r4,r4,r5 + stwx r4,r2,r1 + subi r2,r2,0xc + lvxl v0,r2,r1 + mtvscr v0 + SAVE_INT(r3,19) /* save quotation since we're about to mangle it */ mr r3,r1 /* pass call stack pointer as an argument */ @@ -145,6 +181,22 @@ DEF(void,c_to_factor,(CELL quot)): RESTORE_INT(r3,19) /* restore quotation */ CALL_QUOT + RESTORE_V(v0,104) + mtvscr v0 + + RESTORE_V(v31,100) + RESTORE_V(v30,96) + RESTORE_V(v29,92) + RESTORE_V(v28,88) + RESTORE_V(v27,84) + RESTORE_V(v26,80) + RESTORE_V(v25,76) + RESTORE_V(v24,72) + RESTORE_V(v23,68) + RESTORE_V(v22,64) + RESTORE_V(v21,60) + RESTORE_V(v20,56) + RESTORE_FP(f31,54) RESTORE_FP(f30,52) RESTORE_FP(f29,50) @@ -260,8 +312,8 @@ DEF(void,get_ppc_vmx_env,(void*)): subi r4,r1,16 li r5,0xf andc r4,r4,r5 + stvxl v0,0,r4 li r5,0xc - stvewx v0,r5,r4 lwzx r6,r5,r4 stw r6,0(r3) blr @@ -273,7 +325,7 @@ DEF(void,set_ppc_vmx_env,(const void*)): li r5,0xc lwz r6,0(r3) stwx r6,r5,r4 - lvewx v0,r5,r4 + lvxl v0,0,r4 mtvscr v0 blr From a8d1cd313565865210a5616d57ea382e414026b5 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Philipp=20Br=C3=BCschweiler?= Date: Sun, 13 Sep 2009 21:40:58 +0200 Subject: [PATCH 14/45] xml-rpc: fix post-rpc --- basis/xml-rpc/xml-rpc.factor | 22 +++++++++++++++++----- 1 file changed, 17 insertions(+), 5 deletions(-) diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index 690ebe94f8..370c778787 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel xml arrays math generic http.client -combinators hashtables namespaces io base64 sequences strings -calendar xml.data xml.writer xml.traversal assocs math.parser -debugger calendar.format math.order xml.syntax ; +USING: accessors arrays assocs base64 calendar calendar.format +combinators debugger generic hashtables http http.client +http.client.private io io.encodings.string io.encodings.utf8 +kernel math math.order math.parser namespaces sequences strings +xml xml.data xml.syntax xml.traversal xml.writer ; IN: xml-rpc ! * Sending RPC requests @@ -174,9 +175,20 @@ TAG: array xml>item ] [ "Bad main tag name" server-error ] if ] if ; +string utf8 encode "text/xml" swap >>data ; + +: rpc-post-request ( xml url -- request ) + [ send-rpc xml-post-data ] [ "POST" ] bi* + swap >>post-data ; + +PRIVATE> + : post-rpc ( rpc url -- rpc ) ! This needs to do something in the event of an error - [ send-rpc ] dip http-post nip string>xml receive-rpc ; + rpc-post-request http-request nip string>xml receive-rpc ; : invoke-method ( params method url -- response ) [ swap ] dip post-rpc ; From 044139aa88f30cb00e4b4c051039f5f4ba4426ab Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 13 Sep 2009 15:36:43 -0500 Subject: [PATCH 15/45] add a :NewFactorVocab command to vim plugin --- misc/vim/README | 6 ++++++ misc/vim/plugin/factor.vim | 20 +++++++++++++++++--- 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/misc/vim/README b/misc/vim/README index 0a11654f15..db7e4f09a3 100644 --- a/misc/vim/README +++ b/misc/vim/README @@ -24,6 +24,8 @@ navigating Factor source: :FactorVocab factor.vocab.name Opens the source file implementing the "factor.vocab.name" vocabulary. + :NewFactorVocab factor.vocab.name + Creates a new factor vocabulary under the working vocabulary root. :FactorVocabImpl Opens the main implementation file for the current vocabulary (name.factor). The keyboard shortcut "\fi" is bound to this @@ -46,6 +48,10 @@ variables in your vimrc file: This variable should be set to a list of Factor vocabulary roots. The paths may be either relative to g:FactorRoot or absolute paths. The default value is ["core", "basis", "extra", "work"]. + g:FactorNewVocabRoot + This variable should be set to the vocabulary root in which + vocabularies created with NewFactorVocab should be created. The + default value is "work". Note: The syntax-highlighting file is automatically generated to include the names of all the vocabularies Factor knows about. To regenerate it manually, diff --git a/misc/vim/plugin/factor.vim b/misc/vim/plugin/factor.vim index 61a587aa42..aedae9770f 100644 --- a/misc/vim/plugin/factor.vim +++ b/misc/vim/plugin/factor.vim @@ -10,7 +10,12 @@ if !exists("g:FactorVocabRoots") let g:FactorVocabRoots = ["core", "basis", "extra", "work"] endif +if !exists("g:FactorNewVocabRoot") + let g:FactorNewVocabRoot = "work" +endif + command! -nargs=1 -complete=customlist,FactorCompleteVocab FactorVocab :call GoToFactorVocab("") +command! -nargs=1 -complete=customlist,FactorCompleteVocab NewFactorVocab :call MakeFactorVocab("") command! FactorVocabImpl :call GoToFactorVocabImpl() command! FactorVocabDocs :call GoToFactorVocabDocs() command! FactorVocabTests :call GoToFactorVocabTests() @@ -49,11 +54,11 @@ function! FactorCompleteVocab(arglead, cmdline, cursorpos) return vocabs endfunction -function! FactorVocabFile(root, vocab) +function! FactorVocabFile(root, vocab, mustexist) let vocabpath = substitute(a:vocab, "\\.", "/", "g") let vocabfile = FactorVocabRoot(a:root) . vocabpath . "/" . fnamemodify(vocabpath, ":t") . ".factor" - if getftype(vocabfile) != "" + if !a:mustexist || getftype(vocabfile) != "" return vocabfile else return "" @@ -62,7 +67,7 @@ endfunction function! GoToFactorVocab(vocab) for root in g:FactorVocabRoots - let vocabfile = FactorVocabFile(root, a:vocab) + let vocabfile = FactorVocabFile(root, a:vocab, 1) if vocabfile != "" exe "edit " fnameescape(vocabfile) return @@ -71,6 +76,15 @@ function! GoToFactorVocab(vocab) echo "Vocabulary " vocab " not found" endfunction +function! MakeFactorVocab(vocab) + let vocabfile = FactorVocabFile(g:FactorNewVocabRoot, a:vocab, 0) + echo vocabfile + let vocabdir = fnamemodify(vocabfile, ":h") + echo vocabdir + exe "!mkdir -p " shellescape(vocabdir) + exe "edit " fnameescape(vocabfile) +endfunction + function! FactorFileBase() let filename = expand("%:r") let filename = substitute(filename, "-docs", "", "") From e062cd34dd0d98ef50ebe0b3c195bad6b3b29e6f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 17:19:59 -0500 Subject: [PATCH 16/45] benchmark.simd-1, struct-arrays: reduce memory usage --- extra/benchmark/simd-1/simd-1.factor | 2 +- extra/benchmark/struct-arrays/struct-arrays.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/simd-1/simd-1.factor b/extra/benchmark/simd-1/simd-1.factor index d5576b8cf5..4f57cca0bb 100644 --- a/extra/benchmark/simd-1/simd-1.factor +++ b/extra/benchmark/simd-1/simd-1.factor @@ -25,6 +25,6 @@ IN: benchmark.simd-1 >fixnum make-points [ normalize-points ] [ max-points ] bi print-point ; : main ( -- ) - 5000000 simd-benchmark ; + 10 [ 500000 simd-benchmark ] times ; MAIN: main diff --git a/extra/benchmark/struct-arrays/struct-arrays.factor b/extra/benchmark/struct-arrays/struct-arrays.factor index 799ef2d467..24c3ec965d 100644 --- a/extra/benchmark/struct-arrays/struct-arrays.factor +++ b/extra/benchmark/struct-arrays/struct-arrays.factor @@ -47,6 +47,6 @@ SPECIALIZED-ARRAY: point : struct-array-benchmark ( len -- ) make-points [ normalize-points ] [ max-points ] bi print-point ; -: main ( -- ) 5000000 struct-array-benchmark ; +: main ( -- ) 10 [ 500000 struct-array-benchmark ] times ; MAIN: main From 3ab6dbac22fb462cbe527dbec88445b04b8547eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 18:22:49 -0500 Subject: [PATCH 17/45] math.floats.env: fix compiled trap unit tests --- basis/math/floats/env/env-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index 0c38d69ea9..91b699130a 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -106,7 +106,7 @@ set-default-fp-env append '[ _ _ with-fp-traps ] ; : test-traps-compiled ( traps inputs quot -- quot' ) - swapd '[ _ [ _ _ with-fp-traps ] compile-call ] ; + swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ; { +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail { +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail From abedea0ccb8618a3a2065662c890677fd0ca3431 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 22:33:12 -0500 Subject: [PATCH 18/45] math.functions: loosen tests up a bit since exp(1) on FreeBSD x86/64 differs from e in the last bit --- basis/math/functions/functions-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index cde1c64f94..7a6da72005 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -33,9 +33,9 @@ IN: math.functions.tests [ 0.0 ] [ 1.0 log ] unit-test [ 1.0 ] [ e log ] unit-test -[ t ] [ 1 exp e = ] unit-test -[ t ] [ 1.0 exp e = ] unit-test -[ 1.0 ] [ -1 exp e * ] unit-test +[ t ] [ 1 exp e 1.e-10 ~ ] unit-test +[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test +[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test [ 1.0 ] [ 0 cosh ] unit-test [ 1.0 ] [ 0.0 cosh ] unit-test From a2de9d9e54575e30df2c53930dd62d6dd2688b05 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 23:12:47 -0500 Subject: [PATCH 19/45] compiler.cfg.builder: don't run certain tests if float intrinsics are not available --- .../compiler/cfg/builder/builder-tests.factor | 22 ++++++++++--------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 8da73a1e0e..db0dd65a83 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -192,14 +192,16 @@ IN: compiler.cfg.builder.tests [ [ ##unbox-alien? ] contains-insn? ] bi ] unit-test -[ f t ] [ - [ { byte-array fixnum } declare alien-cell 4 alien-float ] - [ [ ##box-alien? ] contains-insn? ] - [ [ ##box-float? ] contains-insn? ] bi -] unit-test +\ alien-float "intrinsic" word-prop [ + [ f t ] [ + [ { byte-array fixnum } declare alien-cell 4 alien-float ] + [ [ ##box-alien? ] contains-insn? ] + [ [ ##box-float? ] contains-insn? ] bi + ] unit-test -[ f t ] [ - [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ] - [ [ ##box-alien? ] contains-insn? ] - [ [ ##box-float? ] contains-insn? ] bi -] unit-test \ No newline at end of file + [ f t ] [ + [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ] + [ [ ##box-alien? ] contains-insn? ] + [ [ ##box-float? ] contains-insn? ] bi + ] unit-test +] when \ No newline at end of file From 05b51d27393f10c956c87c0699016175866ec418 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 13 Sep 2009 23:26:09 -0500 Subject: [PATCH 20/45] math.floats.env: modify tests to take buggy Linux/x86-64 pow() into account --- basis/math/floats/env/env-tests.factor | 27 ++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index 91b699130a..c1d8913703 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -1,6 +1,7 @@ USING: kernel math math.floats.env math.floats.env.private math.functions math.libm sequences tools.test locals -compiler.units kernel.private fry compiler math.private words ; +compiler.units kernel.private fry compiler math.private words +system ; IN: math.floats.env.tests : set-default-fp-env ( -- ) @@ -29,7 +30,13 @@ set-default-fp-env [ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test [ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test [ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test -[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test + +! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug: +! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113 +os linux? cpu x86.64? and [ + [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test +] unless + [ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test [ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test @@ -108,17 +115,17 @@ set-default-fp-env : test-traps-compiled ( traps inputs quot -- quot' ) swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ; -{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail -{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail -{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail -{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail +{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail -{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail -{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail +{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail { +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail -{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail -{ +fp-underflow+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail +{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail +{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail ! Ensure ordered comparisons raise traps :: test-comparison-quot ( word -- quot ) From fb43ae2daf20c0dc1443663e1ad8e80a0c7b05a4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 13 Sep 2009 23:37:28 -0500 Subject: [PATCH 21/45] save the FP status out of the signal context and use it as part of the fp trap factor exception. clear the FP status before continuing after an exception --- basis/math/floats/env/ppc/ppc.factor | 2 +- vm/cpu-ppc.hpp | 18 +++++++++++ vm/cpu-x86.hpp | 18 +++++++++++ vm/errors.cpp | 7 ++-- vm/errors.hpp | 5 +-- vm/layouts.hpp | 10 ++++++ vm/mach_signal.cpp | 37 ++++++++++++++++----- vm/os-freebsd-x86.32.hpp | 27 ++++++++++++++++ vm/os-freebsd-x86.64.hpp | 21 ++++++++++++ vm/os-linux-x86.32.hpp | 14 ++++++++ vm/os-linux-x86.64.hpp | 14 ++++++++ vm/os-macosx-ppc.hpp | 45 +++++++++++++++++++++++--- vm/os-macosx-x86.32.hpp | 48 +++++++++++++++++++++++++--- vm/os-macosx-x86.64.hpp | 48 +++++++++++++++++++++++++--- vm/os-netbsd-x86.32.hpp | 3 ++ vm/os-netbsd-x86.64.hpp | 3 ++ vm/os-openbsd-x86.32.hpp | 3 ++ vm/os-openbsd-x86.64.hpp | 3 ++ vm/os-unix.cpp | 2 ++ vm/os-windows-nt.cpp | 3 ++ 20 files changed, 303 insertions(+), 28 deletions(-) diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index 4ce3f0512e..dd8fd88b13 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -34,7 +34,7 @@ M: ppc-vmx-env (set-fp-env-register) M: ppc (fp-env-registers) 2array ; -CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000 +CONSTANT: ppc-exception-flag-bits HEX: fff8,0000 CONSTANT: ppc-exception-flag>bit H{ { +fp-invalid-operation+ HEX: 2000,0000 } diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index 6ae2cce27d..db02a72959 100644 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -62,6 +62,24 @@ inline static bool tail_call_site_p(cell return_address) return (insn & 0x1) == 0; } +inline static unsigned int fpu_status(unsigned int status) +{ + unsigned int r = 0; + + if (status & 0x20000000) + r |= FP_TRAP_INVALID_OPERATION; + if (status & 0x10000000) + r |= FP_TRAP_OVERFLOW; + if (status & 0x08000000) + r |= FP_TRAP_UNDERFLOW; + if (status & 0x04000000) + r |= FP_TRAP_ZERO_DIVIDE; + if (status & 0x02000000) + r |= FP_TRAP_INEXACT; + + return r; +} + /* Defined in assembly */ VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind); diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index e5852f9ad9..7054f90735 100644 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -50,6 +50,24 @@ inline static bool tail_call_site_p(cell return_address) return call_site_opcode(return_address) == jmp_opcode; } +inline static unsigned int fpu_status(unsigned int status) +{ + unsigned int r = 0; + + if (status & 0x01) + r |= FP_TRAP_INVALID_OPERATION; + if (status & 0x04) + r |= FP_TRAP_ZERO_DIVIDE; + if (status & 0x08) + r |= FP_TRAP_OVERFLOW; + if (status & 0x10) + r |= FP_TRAP_UNDERFLOW; + if (status & 0x20) + r |= FP_TRAP_INEXACT; + + return r; +} + /* Defined in assembly */ VM_ASM_API void c_to_factor(cell quot); VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to); diff --git a/vm/errors.cpp b/vm/errors.cpp index c9d2a94e56..ebe6201f72 100644 --- a/vm/errors.cpp +++ b/vm/errors.cpp @@ -7,6 +7,7 @@ namespace factor user-space */ cell signal_number; cell signal_fault_addr; +unsigned int signal_fpu_status; stack_frame *signal_callstack_top; void out_of_memory() @@ -130,9 +131,9 @@ void divide_by_zero_error() general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL); } -void fp_trap_error(stack_frame *signal_callstack_top) +void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top) { - general_error(ERROR_FP_TRAP,F,F,signal_callstack_top); + general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top); } PRIMITIVE(call_clear) @@ -158,7 +159,7 @@ void misc_signal_handler_impl() void fp_signal_handler_impl() { - fp_trap_error(signal_callstack_top); + fp_trap_error(signal_fpu_status,signal_callstack_top); } } diff --git a/vm/errors.hpp b/vm/errors.hpp index e4be61cdbf..7f3c4dcd4a 100644 --- a/vm/errors.hpp +++ b/vm/errors.hpp @@ -20,7 +20,7 @@ enum vm_error_type ERROR_RS_UNDERFLOW, ERROR_RS_OVERFLOW, ERROR_MEMORY, - ERROR_FP_TRAP, + ERROR_FP_TRAP, }; void out_of_memory(); @@ -36,7 +36,7 @@ void memory_protection_error(cell addr, stack_frame *native_stack); void signal_error(int signal, stack_frame *native_stack); void type_error(cell type, cell tagged); void not_implemented_error(); -void fp_trap_error(); +void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top); PRIMITIVE(call_clear); PRIMITIVE(unimplemented); @@ -45,6 +45,7 @@ PRIMITIVE(unimplemented); user-space */ extern cell signal_number; extern cell signal_fault_addr; +extern unsigned int signal_fpu_status; extern stack_frame *signal_callstack_top; void memory_signal_handler_impl(); diff --git a/vm/layouts.hpp b/vm/layouts.hpp index 7736143c50..a14c234aaa 100644 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -67,6 +67,16 @@ inline static cell align8(cell a) /* Not a real type, but code_block's type field can be set to this */ #define PIC_TYPE 69 +/* Constants used when floating-point trap exceptions are thrown */ +enum +{ + FP_TRAP_INVALID_OPERATION = 1 << 0, + FP_TRAP_OVERFLOW = 1 << 1, + FP_TRAP_UNDERFLOW = 1 << 2, + FP_TRAP_ZERO_DIVIDE = 1 << 3, + FP_TRAP_INEXACT = 1 << 4, +}; + inline static bool immediate_p(cell obj) { return (obj == F || TAG(obj) == FIXNUM_TYPE); diff --git a/vm/mach_signal.cpp b/vm/mach_signal.cpp index facf512b77..d8eea06f0b 100644 --- a/vm/mach_signal.cpp +++ b/vm/mach_signal.cpp @@ -32,7 +32,8 @@ static void call_fault_handler( exception_type_t exception, exception_data_type_t code, MACH_EXC_STATE_TYPE *exc_state, - MACH_THREAD_STATE_TYPE *thread_state) + MACH_THREAD_STATE_TYPE *thread_state, + MACH_FLOAT_STATE_TYPE *float_state) { /* There is a race condition here, but in practice an exception delivered during stack frame setup/teardown or while transitioning @@ -56,6 +57,8 @@ static void call_fault_handler( } else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV) { + signal_fpu_status = fpu_status(mach_fpu_status(float_state)); + mach_clear_fpu_status(float_state); MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl; } else @@ -78,14 +81,15 @@ catch_exception_raise (mach_port_t exception_port, { MACH_EXC_STATE_TYPE exc_state; MACH_THREAD_STATE_TYPE thread_state; - mach_msg_type_number_t state_count; + MACH_FLOAT_STATE_TYPE float_state; + mach_msg_type_number_t exc_state_count, thread_state_count, float_state_count; /* Get fault information and the faulting thread's register contents.. See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html. */ - state_count = MACH_EXC_STATE_COUNT; + exc_state_count = MACH_EXC_STATE_COUNT; if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR, - (natural_t *)&exc_state, &state_count) + (natural_t *)&exc_state, &exc_state_count) != KERN_SUCCESS) { /* The thread is supposed to be suspended while the exception @@ -93,9 +97,19 @@ catch_exception_raise (mach_port_t exception_port, return KERN_FAILURE; } - state_count = MACH_THREAD_STATE_COUNT; + thread_state_count = MACH_THREAD_STATE_COUNT; if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR, - (natural_t *)&thread_state, &state_count) + (natural_t *)&thread_state, &thread_state_count) + != KERN_SUCCESS) + { + /* The thread is supposed to be suspended while the exception + handler is called. This shouldn't fail. */ + return KERN_FAILURE; + } + + float_state_count = MACH_FLOAT_STATE_COUNT; + if (thread_get_state (thread, MACH_FLOAT_STATE_FLAVOR, + (natural_t *)&float_state, &float_state_count) != KERN_SUCCESS) { /* The thread is supposed to be suspended while the exception @@ -105,13 +119,20 @@ catch_exception_raise (mach_port_t exception_port, /* Modify registers so to have the thread resume executing the fault handler */ - call_fault_handler(exception,code[0],&exc_state,&thread_state); + call_fault_handler(exception,code[0],&exc_state,&thread_state,&float_state); /* Set the faulting thread's register contents.. See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html. */ + if (thread_set_state (thread, MACH_FLOAT_STATE_FLAVOR, + (natural_t *)&float_state, float_state_count) + != KERN_SUCCESS) + { + return KERN_FAILURE; + } + if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR, - (natural_t *)&thread_state, state_count) + (natural_t *)&thread_state, thread_state_count) != KERN_SUCCESS) { return KERN_FAILURE; diff --git a/vm/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp index c276ce6174..e386532b0c 100644 --- a/vm/os-freebsd-x86.32.hpp +++ b/vm/os-freebsd-x86.32.hpp @@ -1,4 +1,5 @@ #include +#include namespace factor { @@ -9,6 +10,32 @@ inline static void *ucontext_stack_pointer(void *uap) return (void *)ucontext->uc_mcontext.mc_esp; } +inline static unsigned int uap_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { + struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); + return x87->en_sw; + } else if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + return xmm->en_sw | xmm->en_mxcsr; + } else + return 0; +} + +inline static void uap_clear_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { + struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); + x87->en_sw = 0; + } else if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + xmm->en_sw = 0; + xmm->en_mxcsr &= 0xffffffc0; + } +} + #define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip) } diff --git a/vm/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp index 6ee491f3ae..78c08447bd 100644 --- a/vm/os-freebsd-x86.64.hpp +++ b/vm/os-freebsd-x86.64.hpp @@ -1,4 +1,5 @@ #include +#include namespace factor { @@ -9,6 +10,26 @@ inline static void *ucontext_stack_pointer(void *uap) return (void *)ucontext->uc_mcontext.mc_rsp; } +inline static unsigned int uap_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + return xmm->en_sw | xmm->en_mxcsr; + } else + return 0; +} + +inline static void uap_clear_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + xmm->en_sw = 0; + xmm->en_mxcsr &= 0xffffffc0; + } +} + #define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip) } diff --git a/vm/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp index 4ba7c77e4b..e4fd8402a8 100644 --- a/vm/os-linux-x86.32.hpp +++ b/vm/os-linux-x86.32.hpp @@ -9,6 +9,20 @@ inline static void *ucontext_stack_pointer(void *uap) return (void *)ucontext->uc_mcontext.gregs[7]; } +inline static unsigned int uap_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return ucontext->uc_mcontext.fpregs->swd + | ucontext->uc_mcontext.fpregs->mxcsr; +} + +inline static void uap_clear_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + ucontext->uc_mcontext.fpregs->swd = 0; + ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0; +} + #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[14]) diff --git a/vm/os-linux-x86.64.hpp b/vm/os-linux-x86.64.hpp index 477e21708c..42adb3c6b8 100644 --- a/vm/os-linux-x86.64.hpp +++ b/vm/os-linux-x86.64.hpp @@ -9,6 +9,20 @@ inline static void *ucontext_stack_pointer(void *uap) return (void *)ucontext->uc_mcontext.gregs[15]; } +inline static unsigned int uap_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + return ucontext->uc_mcontext.fpregs->swd + | ucontext->uc_mcontext.fpregs->mxcsr; +} + +inline static void uap_clear_fpu_status(void *uap) +{ + ucontext_t *ucontext = (ucontext_t *)uap; + ucontext->uc_mcontext.fpregs->swd = 0; + ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0; +} + #define UAP_PROGRAM_COUNTER(ucontext) \ (((ucontext_t *)(ucontext))->uc_mcontext.gregs[16]) diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 62e71bfa69..31a1e22882 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -18,28 +18,63 @@ Modified for Factor by Slava Pestov */ #define MACH_EXC_STATE_TYPE ppc_exception_state_t #define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE #define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT + #define MACH_EXC_INTEGER_DIV EXC_PPC_ZERO_DIVIDE + #define MACH_THREAD_STATE_TYPE ppc_thread_state_t #define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE #define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT +#define MACH_FLOAT_STATE_TYPE ppc_float_state_t +#define MACH_FLOAT_STATE_FLAVOR PPC_FLOAT_STATE +#define MACH_FLOAT_STATE_COUNT PPC_FLOAT_STATE_COUNT + #if __DARWIN_UNIX03 #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar #define MACH_STACK_POINTER(thr_state) (thr_state)->__r1 #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0 - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) + + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) + + #define FPSCR(float_state) (float_state)->__fpscr #else #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar #define MACH_STACK_POINTER(thr_state) (thr_state)->r1 #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0 - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) + + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) + + #define FPSCR(float_state) (float_state)->fpscr #endif +#define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) + +inline static unsigned int mach_fpu_status(ppc_float_state_t *float_state) +{ + return FPSCR(float_state); +} + +inline static unsigned int uap_fpu_status(void *uap) +{ + return mach_fpu_status(UAP_FS(uap)); +} + inline static cell fix_stack_pointer(cell sp) { - return sp; + return sp; +} + +inline static void mach_clear_fpu_status(ppc_float_state_t *float_state) +{ + FPSCR(float_state) &= 0x0007ffff; +} + +inline static void uap_clear_fpu_status(void *uap) +{ + mach_clear_fpu_status(UAP_FS(uap)); } } diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index 2275555846..01ad28df4f 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -16,28 +16,68 @@ Modified for Factor by Slava Pestov */ #define MACH_EXC_STATE_TYPE i386_exception_state_t #define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE #define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT + #define MACH_EXC_INTEGER_DIV EXC_I386_DIV + #define MACH_THREAD_STATE_TYPE i386_thread_state_t #define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE #define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT +#define MACH_FLOAT_STATE_TYPE i386_float_state_t +#define MACH_FLOAT_STATE_FLAVOR i386_FLOAT_STATE +#define MACH_FLOAT_STATE_COUNT i386_FLOAT_STATE_COUNT + #if __DARWIN_UNIX03 #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr #define MACH_STACK_POINTER(thr_state) (thr_state)->__esp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) + + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) + + #define MXCSR(float_state) (float_state)->__fpu_mxcsr + #define X87SW(float_state) (float_state)->__fpu_fsw #else #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr #define MACH_STACK_POINTER(thr_state) (thr_state)->esp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) + + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) + + #define MXCSR(float_state) (float_state)->fpu_mxcsr + #define X87SW(float_state) (float_state)->fpu_fsw #endif +#define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) + +inline static unsigned int mach_fpu_status(i386_float_state_t *float_state) +{ + unsigned short x87sw; + memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw)); + return MXCSR(float_state) | x87sw; +} + +inline static unsigned int uap_fpu_status(void *uap) +{ + return mach_fpu_status(UAP_FS(uap)); +} + inline static cell fix_stack_pointer(cell sp) { return ((sp + 4) & ~15) - 4; } +inline static void mach_clear_fpu_status(i386_float_state_t *float_state) +{ + MXCSR(float_state) &= 0xffffffc0; + memset(&X87SW(float_state), 0, sizeof(X87SW(float_state))); +} + +inline static void uap_clear_fpu_status(void *uap) +{ + mach_clear_fpu_status(UAP_FS(uap)); +} + } diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index b97eb55f26..f56ada23fd 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -16,28 +16,66 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */ #define MACH_EXC_STATE_TYPE x86_exception_state64_t #define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64 #define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT + #define MACH_EXC_INTEGER_DIV EXC_I386_DIV + #define MACH_THREAD_STATE_TYPE x86_thread_state64_t #define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64 #define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT +#define MACH_FLOAT_STATE_TYPE x86_float_state64_t +#define MACH_FLOAT_STATE_FLAVOR x86_FLOAT_STATE64 +#define MACH_FLOAT_STATE_COUNT x86_FLOAT_STATE64_COUNT + #if __DARWIN_UNIX03 #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr #define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss)) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs) + + #define MXCSR(float_state) (float_state)->__fpu_mxcsr + #define X87SW(float_state) (float_state)->__fpu_fsw #else #define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr #define MACH_STACK_POINTER(thr_state) (thr_state)->rsp #define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip - #define UAP_PROGRAM_COUNTER(ucontext) \ - MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss)) + #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss) + #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs) + + #define MXCSR(float_state) (float_state)->fpu_mxcsr + #define X87SW(float_state) (float_state)->fpu_fsw #endif +#define UAP_PROGRAM_COUNTER(ucontext) \ + MACH_PROGRAM_COUNTER(UAP_SS(ucontext)) + +inline static unsigned int mach_fpu_status(x86_float_state64_t *float_state) +{ + unsigned short x87sw; + memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw)); + return MXCSR(float_state) | x87sw; +} + +inline static unsigned int uap_fpu_status(void *uap) +{ + return mach_fpu_status(UAP_FS(uap)); +} + inline static cell fix_stack_pointer(cell sp) { - return ((sp + 8) & ~15) - 8; + return ((sp + 8) & ~15) - 8; +} + +inline static void mach_clear_fpu_status(x86_float_state64_t *float_state) +{ + MXCSR(float_state) &= 0xffffffc0; + memset(&X87SW(float_state), 0, sizeof(X87SW(float_state))); +} + +inline static void uap_clear_fpu_status(void *uap) +{ + mach_clear_fpu_status(UAP_FS(uap)); } } diff --git a/vm/os-netbsd-x86.32.hpp b/vm/os-netbsd-x86.32.hpp index ebba4f356d..f2f47ecf6c 100644 --- a/vm/os-netbsd-x86.32.hpp +++ b/vm/os-netbsd-x86.32.hpp @@ -5,4 +5,7 @@ namespace factor #define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap)) +static inline unsigned int uap_fpu_status(void *uap) { return 0; } +static inline void uap_clear_fpu_status(void *uap) { } + } diff --git a/vm/os-netbsd-x86.64.hpp b/vm/os-netbsd-x86.64.hpp index 1a062cc6ef..a9d52a6c2b 100644 --- a/vm/os-netbsd-x86.64.hpp +++ b/vm/os-netbsd-x86.64.hpp @@ -6,4 +6,7 @@ namespace factor #define ucontext_stack_pointer(uap) \ ((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP])) +static inline unsigned int uap_fpu_status(void *uap) { return 0; } +static inline void uap_clear_fpu_status(void *uap) { } + } diff --git a/vm/os-openbsd-x86.32.hpp b/vm/os-openbsd-x86.32.hpp index 6065d96a5f..0abd019219 100644 --- a/vm/os-openbsd-x86.32.hpp +++ b/vm/os-openbsd-x86.32.hpp @@ -12,4 +12,7 @@ inline static void *openbsd_stack_pointer(void *uap) #define ucontext_stack_pointer openbsd_stack_pointer #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip) +static inline unsigned int uap_fpu_status(void *uap) { return 0; } +static inline void uap_clear_fpu_status(void *uap) { } + } diff --git a/vm/os-openbsd-x86.64.hpp b/vm/os-openbsd-x86.64.hpp index 7338b04e6f..9dce48ee91 100644 --- a/vm/os-openbsd-x86.64.hpp +++ b/vm/os-openbsd-x86.64.hpp @@ -12,4 +12,7 @@ inline static void *openbsd_stack_pointer(void *uap) #define ucontext_stack_pointer openbsd_stack_pointer #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip) +static inline unsigned int uap_fpu_status(void *uap) { return 0; } +static inline void uap_clear_fpu_status(void *uap) { } + } diff --git a/vm/os-unix.cpp b/vm/os-unix.cpp index 735c614b7a..189fca0cf7 100644 --- a/vm/os-unix.cpp +++ b/vm/os-unix.cpp @@ -136,6 +136,8 @@ void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap) { signal_number = signal; signal_callstack_top = uap_stack_pointer(uap); + signal_fpu_status = fpu_status(uap_fpu_status(uap)); + uap_clear_fpu_status(uap); UAP_PROGRAM_COUNTER(uap) = (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF) ? (cell)misc_signal_handler_impl diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index e2d959aace..c2b4e2af9e 100644 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -34,6 +34,9 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) case EXCEPTION_FLT_OVERFLOW: case EXCEPTION_FLT_STACK_CHECK: case EXCEPTION_FLT_UNDERFLOW: + /* XXX MxCsr is not available in CONTEXT structure on x86.32 */ + signal_fpu_status = c->FloatSave.StatusWord; + c->FloatSave.StatusWord = 0; c->EIP = (cell)fp_signal_handler_impl; break; From 8befecbc94ff879a0f82745581853b26104bcc9c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 13 Sep 2009 23:46:21 -0500 Subject: [PATCH 22/45] add tc-lisp-talk vocab --- extra/tc-lisp-talk/authors.txt | 1 + extra/tc-lisp-talk/tc-lisp-talk.factor | 534 +++++++++++++++++++++++++ 2 files changed, 535 insertions(+) create mode 100644 extra/tc-lisp-talk/authors.txt create mode 100644 extra/tc-lisp-talk/tc-lisp-talk.factor diff --git a/extra/tc-lisp-talk/authors.txt b/extra/tc-lisp-talk/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/tc-lisp-talk/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/tc-lisp-talk/tc-lisp-talk.factor b/extra/tc-lisp-talk/tc-lisp-talk.factor new file mode 100644 index 0000000000..cecbc9cb98 --- /dev/null +++ b/extra/tc-lisp-talk/tc-lisp-talk.factor @@ -0,0 +1,534 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs combinators constructors eval help.markup kernel +multiline namespaces parser sequences sequences.private slides +vocabs.refresh words fry ; +IN: tc-lisp-talk + +CONSTANT: tc-lisp-slides +{ + { $slide "Factor!" + { $url "http://factorcode.org" } + "Development started in 2003" + "Open source (BSD license)" + "Influenced by Forth, Lisp, and Smalltalk" + "Blurs the line between language and library" + "Interactive development" + } + { $slide "First, some examples" + { $code "3 weeks ago noon monday ." } + { $code "USE: roman 2009 >roman ." } + { $code <" : average ( seq -- x ) + [ sum ] [ length ] bi / ;"> } + { $code "1 miles [ km ] undo >float ." } + { $code "[ readln eval>string print t ] loop" } + } + { $slide "XML Literals" + { $code + <" USING: splitting xml.writer xml.syntax ; +{ "one" "two" "three" } +[ [XML <-> XML] ] map +<-> XML> pprint-xml"> + } + } + { $slide "Differences between Factor and Lisp" + "Single-implementation language" + "Less nesting, shorter word length" + { "Dynamic reloading of code from files with " { $link refresh-all } } + "More generic protocols -- sequences, assocs, streams" + "More cross-platform" + "No standard for the language" + "Evaluates left to right" + } + { $slide "Terminology" + { "Words - functions" } + { "Vocabularies - collections of code in the same namespace" } + { "Quotations - blocks of code" { $code "[ dup reverse append ]" } } + { "Combinators - higher order functions" } + { "Static stack effect - known stack effect at compile-time" } + } + { $slide "Defining a word" + "Defined at parse time" + "Parts: name, stack effect, definition" + "Composed of tokens separated by whitespace" + { $code ": palindrome? ( string -- ? ) dup reverse = ;" } + } + { $slide "Non-static stack effect" + "Not a good practice, nor useful" + "Not compiled by the optimizing compiler" + { $code "100 iota [ ] each" } + } + { $slide "Module system" + "Code divided up into vocabulary roots" + "core/ -- just enough code to bootstrap Factor" + "basis/ -- optimizing compiler, the UI, tools, libraries" + "extra/ -- demos, unpolished code, experiments" + "work/ -- your works in progress" + } + { $slide "Module system (part 2)" + "Each vocabulary corresponds to a directory on disk, with documentation and test files" + { "Code for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math.factor" } } + { "Documentation for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math-docs.factor" } } + { "Unit tests for the " { $snippet "math" } " vocabulary: " { $snippet " ~/factor/core/math/math-tests.factor" } } + } + { $slide "Using a library" + "Each file starts with a USING: list" + "To use a library, simply include it in this list" + "Refreshing code loads dependencies correctly" + } + { $slide "Object system" + "Based on CLOS" + { "We define generic words that operate on the top of the stack with " { $link POSTPONE: GENERIC: } " or on an implicit parameter with " { $link POSTPONE: HOOK: } } + } + { $slide "Object system example: shape protocol" + "In ~/factor/work/shapes/shapes.factor" + { $code <" IN: shapes + +GENERIC: area ( shape -- x ) +GENERIC: perimeter ( shape -- x )"> + } + } + { $slide "Implementing the shape protocol: circles" + "In ~/factor/work/shapes/circle/circle.factor" + { $code <" USING: shapes constructors math +math.constants ; +IN: shapes.circle + +TUPLE: circle radius ; +CONSTRUCTOR: circle ( radius -- obj ) ; +M: circle area radius>> sq pi * ; +M: circle perimeter radius>> pi * 2 * ;"> + } + } + { $slide "Dynamic variables" + "Implemented as a stack of hashtables" + { "Useful words are " { $link get } ", " { $link set } } + "Input, output, error streams are stored in dynamic variables" + { $code <" "Today is the first day of the rest of your life." +[ + readln print +] with-string-reader"> + } + } + { $slide "The global namespace" + "The global namespace is just the namespace at the bottom of the namespace stack" + { "Useful words are " { $link get-global } ", " { $link set-global } } + "Factor idiom for changing a particular namespace" + { $code <" SYMBOL: king +global [ "Henry VIII" king set ] bind"> + } + { $code "with-scope" } + { $code "namestack" } + } + { $slide "Hooks" + "Dispatch on a dynamic variable" + { $code <" HOOK: computer-name os ( -- string ) +M: macosx computer-name uname first ; +macosx \ os set-global +computer-name"> + } + } + { $slide "Interpolate" + "Replaces variables in a string" + { $code +<" "Dawg" "name" set +"rims" "noun" set +"bling" "verb1" set +"roll" "verb2" set +[ + "Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your car so you can ${verb1} while you ${verb2}." + interpolate +] with-string-writer print "> + } + } + { $slide "Sequence protocol" + "All sequences obey a protocol of generics" + { "Is an object a " { $link sequence? } } + { "Getting the " { $link length } } + { "Accessing the " { $link nth } " element" } + { "Setting an element - " { $link set-nth } } + } + { $slide "Examples of sequences in Factor" + "Arrays are mutable" + "Vectors are mutable and growable" + { "Arrays " { $code "{ \"abc\" \"def\" 50 }" } } + { "Vectors " { $code "V{ \"abc\" \"def\" 50 }" } } + { "Byte-arrays " { $code "B{ 1 2 3 }" } } + { "Byte-vectors " { $code "BV{ 11 22 33 }" } } + } + { $slide "Specialized arrays and vectors" + { "Specialized int arrays " { $code "int-array{ -20 -30 40 }" } } + { "Specialized uint arrays " { $code "uint-array{ 20 30 40 }" } } + { "Specialized float vectors " { $code "float-vector{ 20 30 40 }" } } + "35 others C-type arrays" + } + { $slide "Specialized arrays code" + "One line per array/vector" + { "In ~/factor/basis/specialized-arrays/float/float.factor" + { $code <" << "float" define-array >>"> } + } + { "In ~/factor/basis/specialized-vectors/float/float.factor" + { $code <" << "float" define-vector >>"> } + } + } + + { $slide "Speciailzied arrays are implemented using functors" + "Like C++ templates" + "Eliminate boilerplate in ways other abstractions don't" + "Contains a definition section and a functor body" + "Uses the interpolate vocabulary" + } + { $slide "Functor for sorting" + { $code + <" FUNCTOR: define-sorting ( NAME QUOT -- ) + +NAME<=> DEFINES ${NAME}<=> +NAME>=< DEFINES ${NAME}>=< + +WHERE + +: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ; +: NAME>=< ( obj1 obj2 -- >=< ) + NAME<=> invert-comparison ; + +;FUNCTOR"> + } + } + { $slide "Example of sorting functor" + { $code <" USING: sorting.functor ; +<< "length" [ length ] define-sorting >>"> + } + { $code + <" { { 1 2 3 } { 1 2 } { 1 } } +[ length<=> ] sort"> + } + } + { $slide "Combinators" + "Used to implement higher order functions (dataflow and control flow)" + "Compiler optimizes away quotations completely" + "Optimized code is just tight loops in registers" + "Most loops can be expressed with combinators or tail-recursion" + } + { $slide "Combinators that act on one value" + { $link bi } + { $code "10 [ 1 - ] [ 1 + ] bi" } + { $link tri } + { $code "10 [ 1 - ] [ 1 + ] [ 2 * ] tri" } + } + { $slide "Combinators that act on two values" + { $link 2bi } + { $code "10 1 [ - ] [ + ] 2bi" } + { $link bi* } + { $code "10 20 [ 1 - ] [ 1 + ] bi*" } + { $link bi@ } + { $code "5 9 [ sq ] bi@" } + } + { $slide "Sequence combinators" + + { $link each } + { $code "{ 1 2 3 4 5 } [ sq . ] each" } + { $link map } + { $code "{ 1 2 3 4 5 } [ sq ] map" } + { $link filter } + { $code "{ 1 2 3 4 5 } [ even? ] filter" } + } + { $slide "Multiple sequence combinators" + + { $link 2each } + { $code "{ 1 2 3 } { 10 20 30 } [ + . ] 2each" } + { $link 2map } + { $code "{ 1 2 3 } { 10 20 30 } [ + ] 2map" } + } + { $slide "Control flow: if" + { $link if } + { $code <" 10 random dup even? [ 2 / ] [ 1 - ] if"> } + { $link when } + { $code <" 10 random dup even? [ 2 / ] when"> } + { $link unless } + { $code <" 10 random dup even? [ 1 - ] unless"> } + } + { $slide "Control flow: case" + { $link case } + { $code <" ERROR: not-possible obj ; +10 random 5 <=> { + { +lt+ [ "Less" ] } + { +gt+ [ "More" ] } + { +eq+ [ "Equal" ] } + [ not-possible ] +} case"> + } + } + { $slide "Fry" + "Used to construct quotations" + { "'Holes', represented by " { $snippet "_" } " are filled left to right" } + { $code "10 4 '[ _ + ] call" } + { $code "3 4 '[ _ sq _ + ] call" } + } + { $slide "Locals" + "When data flow combinators and shuffle words are not enough" + "Name your input parameters" + "Used in about 1% of all words" + } + { $slide "Locals example" + "Area of a triangle using Heron's formula" + { $code + <" :: area ( a b c -- x ) + a b c + + 2 / :> p + p + p a - * + p b - * + p c - * sqrt ;"> + } + } + { $slide "Previous example without locals" + "A bit unwieldy..." + { $code + <" : area ( a b c -- x ) + [ ] [ + + 2 / ] 3bi + [ '[ _ - ] tri@ ] [ neg ] bi + * * * sqrt ;"> } + } + { $slide "More idiomatic version" + "But there's a trick: put the lengths in an array" + { $code <" : v-n ( v n -- w ) '[ _ - ] map ; + +: area ( seq -- x ) + [ 0 suffix ] [ sum 2 / ] bi + v-n product sqrt ;"> } + } + { $slide "Implementing an abstraction" + { "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" } + { $code + "dup [ orders>> ] when" + "dup [ first ] when" + "dup [ price>> ] when" + } + } + { $slide "This is hard with mainstream syntax!" + { $code + <" var customer = ...; +var orders = (customer == null ? null : customer.orders); +var order = (orders == null ? null : orders[0]); +var price = (order == null ? null : order.price);"> } + } + { $slide "An ad-hoc solution" + "Something like..." + { $code "var price = customer.?orders.?[0].?price;" } + } + { $slide "Macros in Factor" + "Expand at compile-time" + "Return a quotation to be compiled" + "Can express non-static stack effects" + "Not as widely used as combinators, 60 macros so far" + { $code "{ 1 2 3 4 5 } 5 firstn" } + } + { $slide "A macro solution" + "Returns a quotation to the compiler" + "Constructed using map, fry, and concat" + { $code <" MACRO: plox ( seq -- quot ) + [ + '[ dup _ when ] + ] map [ ] concat-as ;"> + } + } + { $slide "Macro example" + "Return the caaar of a sequence" + { "Return " { $snippet f } " on failure" } + { $code <" : caaar ( seq/f -- x/f ) + { + [ first ] + [ first ] + [ first ] + } plox ;"> + } + { $code <" { { f } } caaar"> } + { $code <" { { { 1 2 3 } } } caaar"> } + } + { $slide "Smart combinators" + "Use stack checker to infer inputs and outputs" + "Even fewer uses than macros" + { $code "{ 1 10 20 34 } sum" } + { $code "[ 1 10 20 34 ] sum-outputs" } + { $code "[ 2 2 [ even? ] both? ] [ + ] [ - ] smart-if" } + } + { $slide "Fibonacci" + "Not tail recursive" + "Call tree is huge" + { $code <" : fib ( n -- x ) + dup 1 <= [ + [ 1 - fib ] [ 2 - fib ] bi + + ] unless ;"> + } + { $code "36 iota [ fib ] map ." } + } + { $slide "Memoized Fibonacci" + "Change one word and it's efficient" + { $code <" MEMO: fib ( n -- x ) + dup 1 <= [ + [ 1 - fib ] [ 2 - fib ] bi + + ] unless ;"> + } + { $code "36 iota [ fib ] map ." } + } + { $slide "Destructors" + "Deterministic resource disposal" + "Any step can fail and we don't want to leak resources" + "We want to conditionally clean up sometimes -- if everything succeeds, we might wish to retain the buffer" + } + + { $slide "Example in C" + { $code +<" void do_stuff() +{ + void *obj1, *obj2; + if(!(*obj1 = malloc(256))) goto end; + if(!(*obj2 = malloc(256))) goto cleanup1; + ... work goes here... +cleanup2: free(*obj2); +cleanup1: free(*obj1); +end: return; +}"> + } + } + { $slide "Example: allocating and disposing two buffers" + { $code <" : do-stuff ( -- ) + [ + 256 malloc &free + 256 malloc &free + ... work goes here ... + ] with-destructors ;"> + } + } + { $slide "Example: allocating two buffers for later" + { $code <" : do-stuff ( -- ) + [ + 256 malloc |free + 256 malloc |free + ... work goes here ... + ] with-destructors ;"> + } + } + { $slide "Example: disposing of an output port" + { $code <" M: output-port dispose* + [ + { + [ handle>> &dispose drop ] + [ buffer>> &dispose drop ] + [ port-flush ] + [ handle>> shutdown ] + } cleave + ] with-destructors ;"> + } + } + { $slide "Rapid application development" + "We lost the dice to Settlers of Catan: Cities and Knights" + "Two regular dice, one special die" + { $vocab-link "dice" } + } + { $slide "The essence of Factor" + "Nicely named words abstract away the stack, leaving readable code" + { $code <" : surround ( seq left right -- seq' ) + swapd 3append ;"> + } + { $code <" : glue ( left right middle -- seq' ) + swap 3append ;"> + } + { $code HEREDOC: xyz +"a" "b" "c" 3append +"a" "<" ">" surround +"a" "b" ", " glue +xyz + } + } + { $slide "C FFI demo" + "Easy to call C functions from Factor" + "Handles C structures, C types, callbacks" + "Used extensively in the Windows and Unix backends" + { $code + <" FUNCTION: double pow ( double x, double y ) ; +2 5.0 pow ."> + } + } + { $slide "Windows win32 example" + { $code +<" M: windows gmt-offset + ( -- hours minutes seconds ) + "TIME_ZONE_INFORMATION" + dup GetTimeZoneInformation { + { TIME_ZONE_ID_INVALID [ + win32-error-string throw + ] } + { TIME_ZONE_ID_STANDARD [ + TIME_ZONE_INFORMATION-Bias + ] } + } case neg 60 /mod 0 ;"> + } + } + { $slide "Struct and function" + { $code <" C-STRUCT: TIME_ZONE_INFORMATION + { "LONG" "Bias" } + { { "WCHAR" 32 } "StandardName" } + { "SYSTEMTIME" "StandardDate" } + { "LONG" "StandardBias" } + { { "WCHAR" 32 } "DaylightName" } + { "SYSTEMTIME" "DaylightDate" } + { "LONG" "DaylightBias" } ;"> + } + { $code <" FUNCTION: DWORD GetTimeZoneInformation ( + LPTIME_ZONE_INFORMATION + lpTimeZoneInformation +) ;"> + } + + } + { $slide "Cocoa FFI" + { $code <" IMPORT: NSAlert [ + NSAlert -> new + [ -> retain ] [ + "Raptor" &CFRelease + -> setMessageText: + ] [ + "Look out!" &CFRelease + -> setInformativeText: + ] tri -> runModal drop +] with-destructors"> + } + } + { $slide "Deployment demo" + "Vocabularies can be deployed" + "Standalone .app on Mac" + "An executable and dll on Windows" + { $vocab-link "webkit-demo" } + } + { $slide "Interesting programs" + { $vocab-link "terrain" } + { $vocab-link "gpu.demos.raytrace" } + { $vocab-link "gpu.demos.bunny" } + } + { $slide "Factor's source tree" + "Lines of code in core/: 9,500" + "Lines of code in basis/: 120,000" + "Lines of code in extra/: 51,000" + "Lines of tests: 44,000" + "Lines of documentation: 44,500" + } + { $slide "VM trivia" + "Lines of C++ code: 12860" + "Generational garbage collection" + "Non-optimizing compiler" + "Loads an image file and runs it" + } + { $slide "Why should I use Factor?" + "More abstractions over time" + "We fix reported bugs quickly" + "Stackable, fluent language" + "Supports extreme programming" + "Beer-friendly programming" + } + { $slide "Questions?" + } +} + +: tc-lisp-talk ( -- ) tc-lisp-slides slides-window ; + +MAIN: tc-lisp-talk From 198874aea896c56359d388cdf6c78480009820ac Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 00:00:01 -0500 Subject: [PATCH 23/45] fix compilation on freebsd --- vm/os-freebsd-x86.32.hpp | 14 +++++++------- vm/os-freebsd-x86.64.hpp | 10 +++++----- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/vm/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp index e386532b0c..800b343dfd 100644 --- a/vm/os-freebsd-x86.32.hpp +++ b/vm/os-freebsd-x86.32.hpp @@ -13,12 +13,12 @@ inline static void *ucontext_stack_pointer(void *uap) inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { + if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); - return x87->en_sw; - } else if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { + return x87->sv_env.en_sw; + } else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - return xmm->en_sw | xmm->en_mxcsr; + return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr; } else return 0; } @@ -28,11 +28,11 @@ inline static void uap_clear_fpu_status(void *uap) ucontext_t *ucontext = (ucontext_t *)uap; if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); - x87->en_sw = 0; + x87->sv_env.en_sw = 0; } else if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - xmm->en_sw = 0; - xmm->en_mxcsr &= 0xffffffc0; + xmm->sv_env.en_sw = 0; + xmm->sv_env.en_mxcsr &= 0xffffffc0; } } diff --git a/vm/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp index 78c08447bd..b2dd096137 100644 --- a/vm/os-freebsd-x86.64.hpp +++ b/vm/os-freebsd-x86.64.hpp @@ -13,9 +13,9 @@ inline static void *ucontext_stack_pointer(void *uap) inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { + if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - return xmm->en_sw | xmm->en_mxcsr; + return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr; } else return 0; } @@ -23,10 +23,10 @@ inline static unsigned int uap_fpu_status(void *uap) inline static void uap_clear_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { + if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - xmm->en_sw = 0; - xmm->en_mxcsr &= 0xffffffc0; + xmm->sv_env.en_sw = 0; + xmm->sv_env.en_mxcsr &= 0xffffffc0; } } From c4f3a4226930fe682adba546b0bc76379df3b182 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 02:39:12 -0500 Subject: [PATCH 24/45] math.floats.env: Fix linux x86.64 some more --- basis/math/floats/env/env-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/floats/env/env-tests.factor b/basis/math/floats/env/env-tests.factor index c1d8913703..7f5a20efd0 100644 --- a/basis/math/floats/env/env-tests.factor +++ b/basis/math/floats/env/env-tests.factor @@ -21,7 +21,6 @@ set-default-fp-env [ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test [ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test [ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test -[ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test [ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test [ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test @@ -34,6 +33,7 @@ set-default-fp-env ! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug: ! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113 os linux? cpu x86.64? and [ + [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test ] unless From 83c992173e70c8eeabee55d649fcfeac1d75f3c1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 03:09:03 -0500 Subject: [PATCH 25/45] vm: fix indentation in Joe's changes --- vm/cpu-ppc.hpp | 10 +++---- vm/cpu-x86.hpp | 12 ++++----- vm/float_bits.hpp | 8 +++--- vm/layouts.hpp | 10 +++---- vm/os-freebsd-x86.32.hpp | 37 +++++++++++++++----------- vm/os-freebsd-x86.64.hpp | 21 ++++++++------- vm/os-macosx-ppc.hpp | 10 +++---- vm/os-macosx-x86.32.hpp | 10 +++---- vm/os-macosx-x86.64.hpp | 16 +++++------ vm/os-netbsd.hpp | 2 -- vm/os-windows-nt.cpp | 57 ++++++++++++++++++++-------------------- 11 files changed, 100 insertions(+), 93 deletions(-) diff --git a/vm/cpu-ppc.hpp b/vm/cpu-ppc.hpp index db02a72959..2124e03350 100644 --- a/vm/cpu-ppc.hpp +++ b/vm/cpu-ppc.hpp @@ -67,15 +67,15 @@ inline static unsigned int fpu_status(unsigned int status) unsigned int r = 0; if (status & 0x20000000) - r |= FP_TRAP_INVALID_OPERATION; + r |= FP_TRAP_INVALID_OPERATION; if (status & 0x10000000) - r |= FP_TRAP_OVERFLOW; + r |= FP_TRAP_OVERFLOW; if (status & 0x08000000) - r |= FP_TRAP_UNDERFLOW; + r |= FP_TRAP_UNDERFLOW; if (status & 0x04000000) - r |= FP_TRAP_ZERO_DIVIDE; + r |= FP_TRAP_ZERO_DIVIDE; if (status & 0x02000000) - r |= FP_TRAP_INEXACT; + r |= FP_TRAP_INEXACT; return r; } diff --git a/vm/cpu-x86.hpp b/vm/cpu-x86.hpp index 7054f90735..4a37a17889 100644 --- a/vm/cpu-x86.hpp +++ b/vm/cpu-x86.hpp @@ -53,17 +53,17 @@ inline static bool tail_call_site_p(cell return_address) inline static unsigned int fpu_status(unsigned int status) { unsigned int r = 0; - + if (status & 0x01) - r |= FP_TRAP_INVALID_OPERATION; + r |= FP_TRAP_INVALID_OPERATION; if (status & 0x04) - r |= FP_TRAP_ZERO_DIVIDE; + r |= FP_TRAP_ZERO_DIVIDE; if (status & 0x08) - r |= FP_TRAP_OVERFLOW; + r |= FP_TRAP_OVERFLOW; if (status & 0x10) - r |= FP_TRAP_UNDERFLOW; + r |= FP_TRAP_UNDERFLOW; if (status & 0x20) - r |= FP_TRAP_INEXACT; + r |= FP_TRAP_INEXACT; return r; } diff --git a/vm/float_bits.hpp b/vm/float_bits.hpp index 000bd49482..73a04639ee 100644 --- a/vm/float_bits.hpp +++ b/vm/float_bits.hpp @@ -5,8 +5,8 @@ namespace factor representations and vice versa */ union double_bits_pun { - double x; - u64 y; + double x; + u64 y; }; inline static u64 double_bits(double x) @@ -24,8 +24,8 @@ inline static double bits_double(u64 y) } union float_bits_pun { - float x; - u32 y; + float x; + u32 y; }; inline static u32 float_bits(float x) diff --git a/vm/layouts.hpp b/vm/layouts.hpp index a14c234aaa..dceb9a208a 100644 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -70,11 +70,11 @@ inline static cell align8(cell a) /* Constants used when floating-point trap exceptions are thrown */ enum { - FP_TRAP_INVALID_OPERATION = 1 << 0, - FP_TRAP_OVERFLOW = 1 << 1, - FP_TRAP_UNDERFLOW = 1 << 2, - FP_TRAP_ZERO_DIVIDE = 1 << 3, - FP_TRAP_INEXACT = 1 << 4, + FP_TRAP_INVALID_OPERATION = 1 << 0, + FP_TRAP_OVERFLOW = 1 << 1, + FP_TRAP_UNDERFLOW = 1 << 2, + FP_TRAP_ZERO_DIVIDE = 1 << 3, + FP_TRAP_INEXACT = 1 << 4, }; inline static bool immediate_p(cell obj) diff --git a/vm/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp index 800b343dfd..a0888e1f5b 100644 --- a/vm/os-freebsd-x86.32.hpp +++ b/vm/os-freebsd-x86.32.hpp @@ -13,26 +13,33 @@ inline static void *ucontext_stack_pointer(void *uap) inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { - struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); - return x87->sv_env.en_sw; - } else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { - struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr; - } else - return 0; + if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387) + { + struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); + return x87->sv_env.en_sw; + } + else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) + { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr; + } + else + return 0; } inline static void uap_clear_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { - struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); - x87->sv_env.en_sw = 0; - } else if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { - struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - xmm->sv_env.en_sw = 0; - xmm->sv_env.en_mxcsr &= 0xffffffc0; + if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_387) + { + struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); + x87->sv_env.en_sw = 0; + } + else if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) + { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + xmm->sv_env.en_sw = 0; + xmm->sv_env.en_mxcsr &= 0xffffffc0; } } diff --git a/vm/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp index b2dd096137..6200a0f5f3 100644 --- a/vm/os-freebsd-x86.64.hpp +++ b/vm/os-freebsd-x86.64.hpp @@ -13,20 +13,23 @@ inline static void *ucontext_stack_pointer(void *uap) inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { - struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr; - } else - return 0; + if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) + { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr; + } + else + return 0; } inline static void uap_clear_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { - struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); - xmm->sv_env.en_sw = 0; - xmm->sv_env.en_mxcsr &= 0xffffffc0; + if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) + { + struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + xmm->sv_env.en_sw = 0; + xmm->sv_env.en_mxcsr &= 0xffffffc0; } } diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 31a1e22882..338e3e812f 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -54,27 +54,27 @@ Modified for Factor by Slava Pestov */ inline static unsigned int mach_fpu_status(ppc_float_state_t *float_state) { - return FPSCR(float_state); + return FPSCR(float_state); } inline static unsigned int uap_fpu_status(void *uap) { - return mach_fpu_status(UAP_FS(uap)); + return mach_fpu_status(UAP_FS(uap)); } inline static cell fix_stack_pointer(cell sp) { - return sp; + return sp; } inline static void mach_clear_fpu_status(ppc_float_state_t *float_state) { - FPSCR(float_state) &= 0x0007ffff; + FPSCR(float_state) &= 0x0007ffff; } inline static void uap_clear_fpu_status(void *uap) { - mach_clear_fpu_status(UAP_FS(uap)); + mach_clear_fpu_status(UAP_FS(uap)); } } diff --git a/vm/os-macosx-x86.32.hpp b/vm/os-macosx-x86.32.hpp index 01ad28df4f..89906cd9a4 100644 --- a/vm/os-macosx-x86.32.hpp +++ b/vm/os-macosx-x86.32.hpp @@ -54,14 +54,14 @@ Modified for Factor by Slava Pestov */ inline static unsigned int mach_fpu_status(i386_float_state_t *float_state) { - unsigned short x87sw; - memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw)); - return MXCSR(float_state) | x87sw; + unsigned short x87sw; + memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw)); + return MXCSR(float_state) | x87sw; } inline static unsigned int uap_fpu_status(void *uap) { - return mach_fpu_status(UAP_FS(uap)); + return mach_fpu_status(UAP_FS(uap)); } inline static cell fix_stack_pointer(cell sp) @@ -77,7 +77,7 @@ inline static void mach_clear_fpu_status(i386_float_state_t *float_state) inline static void uap_clear_fpu_status(void *uap) { - mach_clear_fpu_status(UAP_FS(uap)); + mach_clear_fpu_status(UAP_FS(uap)); } } diff --git a/vm/os-macosx-x86.64.hpp b/vm/os-macosx-x86.64.hpp index f56ada23fd..fd6db4d68c 100644 --- a/vm/os-macosx-x86.64.hpp +++ b/vm/os-macosx-x86.64.hpp @@ -52,30 +52,30 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */ inline static unsigned int mach_fpu_status(x86_float_state64_t *float_state) { - unsigned short x87sw; - memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw)); - return MXCSR(float_state) | x87sw; + unsigned short x87sw; + memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw)); + return MXCSR(float_state) | x87sw; } inline static unsigned int uap_fpu_status(void *uap) { - return mach_fpu_status(UAP_FS(uap)); + return mach_fpu_status(UAP_FS(uap)); } inline static cell fix_stack_pointer(cell sp) { - return ((sp + 8) & ~15) - 8; + return ((sp + 8) & ~15) - 8; } inline static void mach_clear_fpu_status(x86_float_state64_t *float_state) { - MXCSR(float_state) &= 0xffffffc0; - memset(&X87SW(float_state), 0, sizeof(X87SW(float_state))); + MXCSR(float_state) &= 0xffffffc0; + memset(&X87SW(float_state), 0, sizeof(X87SW(float_state))); } inline static void uap_clear_fpu_status(void *uap) { - mach_clear_fpu_status(UAP_FS(uap)); + mach_clear_fpu_status(UAP_FS(uap)); } } diff --git a/vm/os-netbsd.hpp b/vm/os-netbsd.hpp index 635361e3e4..d45b2ac163 100644 --- a/vm/os-netbsd.hpp +++ b/vm/os-netbsd.hpp @@ -5,6 +5,4 @@ namespace factor #define UAP_PROGRAM_COUNTER(uap) _UC_MACHINE_PC((ucontext_t *)uap) -#define DIRECTORY_P(file) ((file)->d_type == DT_DIR) - } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp index c2b4e2af9e..017a96bb7c 100644 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -21,40 +21,39 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) else signal_callstack_top = NULL; - switch (e->ExceptionCode) { - case EXCEPTION_ACCESS_VIOLATION: + switch (e->ExceptionCode) + { + case EXCEPTION_ACCESS_VIOLATION: signal_fault_addr = e->ExceptionInformation[1]; c->EIP = (cell)memory_signal_handler_impl; - break; + break; - case EXCEPTION_FLT_DENORMAL_OPERAND: - case EXCEPTION_FLT_DIVIDE_BY_ZERO: - case EXCEPTION_FLT_INEXACT_RESULT: - case EXCEPTION_FLT_INVALID_OPERATION: - case EXCEPTION_FLT_OVERFLOW: - case EXCEPTION_FLT_STACK_CHECK: - case EXCEPTION_FLT_UNDERFLOW: - /* XXX MxCsr is not available in CONTEXT structure on x86.32 */ - signal_fpu_status = c->FloatSave.StatusWord; - c->FloatSave.StatusWord = 0; - c->EIP = (cell)fp_signal_handler_impl; - break; - - /* If the Widcomm bluetooth stack is installed, the BTTray.exe process - injects code into running programs. For some reason this results in - random SEH exceptions with this (undocumented) exception code being - raised. The workaround seems to be ignoring this altogether, since that - is what happens if SEH is not enabled. Don't really have any idea what - this exception means. */ - case 0x40010006: - break; - - default: + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INEXACT_RESULT: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + /* XXX MxCsr is not available in CONTEXT structure on x86.32 */ + signal_fpu_status = c->FloatSave.StatusWord; + c->FloatSave.StatusWord = 0; + c->EIP = (cell)fp_signal_handler_impl; + break; + case 0x40010006: + /* If the Widcomm bluetooth stack is installed, the BTTray.exe + process injects code into running programs. For some reason this + results in random SEH exceptions with this (undocumented) + exception code being raised. The workaround seems to be ignoring + this altogether, since that is what happens if SEH is not + enabled. Don't really have any idea what this exception means. */ + break; + default: signal_number = e->ExceptionCode; c->EIP = (cell)misc_signal_handler_impl; - break; - } - return EXCEPTION_CONTINUE_EXECUTION; + break; + } + return EXCEPTION_CONTINUE_EXECUTION; } void c_to_factor_toplevel(cell quot) From 448b89f585fb52bc1d34fdea7c4adabe1790e854 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 03:14:48 -0500 Subject: [PATCH 26/45] vm: More indentation fixes --- vm/cpu-ppc.S | 73 ++++++++++++++++---------------- vm/cpu-x86.32.S | 28 ++++++------ vm/cpu-x86.64.S | 20 ++++----- vm/cpu-x86.S | 110 ++++++++++++++++++++++++------------------------ 4 files changed, 115 insertions(+), 116 deletions(-) diff --git a/vm/cpu-ppc.S b/vm/cpu-ppc.S index 342ec83d7e..e7a210b7aa 100644 --- a/vm/cpu-ppc.S +++ b/vm/cpu-ppc.S @@ -88,11 +88,12 @@ multiply_overflow: #define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1) #define SAVE_V(register,offset) \ - li r2,SAVE_AT(offset) XX \ - stvxl register,r2,r1 + li r2,SAVE_AT(offset) XX \ + stvxl register,r2,r1 + #define RESTORE_V(register,offset) \ - li r2,SAVE_AT(offset) XX \ - lvxl register,r2,r1 + li r2,SAVE_AT(offset) XX \ + lvxl register,r2,r1 #define PROLOGUE \ mflr r0 XX /* get caller's return address */ \ @@ -104,8 +105,6 @@ multiply_overflow: lwz r1,0(r1) XX /* destroy the stack frame */ \ mtlr r0 /* get ready to return */ - - /* We have to save and restore nonvolatile registers because the Factor compiler treats the entire register file as volatile. */ DEF(void,c_to_factor,(CELL quot)): @@ -288,44 +287,44 @@ DEF(void,flush_icache,(void *start, int len)): blr DEF(void,primitive_inline_cache_miss,(void)): - mflr r6 + mflr r6 DEF(void,primitive_inline_cache_miss_tail,(void)): - PROLOGUE - mr r3,r6 - bl MANGLE(inline_cache_miss) - EPILOGUE - mtctr r3 - bctr + PROLOGUE + mr r3,r6 + bl MANGLE(inline_cache_miss) + EPILOGUE + mtctr r3 + bctr DEF(void,get_ppc_fpu_env,(void*)): - mffs f0 - stfd f0,0(r3) - blr + mffs f0 + stfd f0,0(r3) + blr DEF(void,set_ppc_fpu_env,(const void*)): - lfd f0,0(r3) - mtfsf 0xff,f0 - blr + lfd f0,0(r3) + mtfsf 0xff,f0 + blr DEF(void,get_ppc_vmx_env,(void*)): - mfvscr v0 - subi r4,r1,16 - li r5,0xf - andc r4,r4,r5 - stvxl v0,0,r4 - li r5,0xc - lwzx r6,r5,r4 - stw r6,0(r3) - blr + mfvscr v0 + subi r4,r1,16 + li r5,0xf + andc r4,r4,r5 + stvxl v0,0,r4 + li r5,0xc + lwzx r6,r5,r4 + stw r6,0(r3) + blr DEF(void,set_ppc_vmx_env,(const void*)): - subi r4,r1,16 - li r5,0xf - andc r4,r4,r5 - li r5,0xc - lwz r6,0(r3) - stwx r6,r5,r4 - lvxl v0,0,r4 - mtvscr v0 - blr + subi r4,r1,16 + li r5,0xf + andc r4,r4,r5 + li r5,0xc + lwz r6,0(r3) + stwx r6,r5,r4 + lvxl v0,0,r4 + mtvscr v0 + blr diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index 0c4166cfe5..87a0e03f99 100644 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -58,26 +58,26 @@ DEF(void,primitive_inline_cache_miss_tail,(void)): jmp *%eax DEF(void,get_sse_env,(void*)): - movl 4(%esp), %eax - stmxcsr (%eax) - ret + movl 4(%esp), %eax + stmxcsr (%eax) + ret DEF(void,set_sse_env,(const void*)): - movl 4(%esp), %eax - ldmxcsr (%eax) - ret + movl 4(%esp), %eax + ldmxcsr (%eax) + ret DEF(void,get_x87_env,(void*)): - movl 4(%esp), %eax - fnstsw (%eax) - fnstcw 2(%eax) - ret + movl 4(%esp), %eax + fnstsw (%eax) + fnstcw 2(%eax) + ret DEF(void,set_x87_env,(const void*)): - movl 4(%esp), %eax - fnclex - fldcw 2(%eax) - ret + movl 4(%esp), %eax + fnclex + fldcw 2(%eax) + ret #include "cpu-x86.S" diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index e6d9d88810..0da360e675 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -89,21 +89,21 @@ DEF(void,primitive_inline_cache_miss_tail,(void)): jmp *%rax DEF(void,get_sse_env,(void*)): - stmxcsr (%rdi) - ret + stmxcsr (%rdi) + ret DEF(void,set_sse_env,(const void*)): - ldmxcsr (%rdi) - ret + ldmxcsr (%rdi) + ret DEF(void,get_x87_env,(void*)): - fnstsw (%rdi) - fnstcw 2(%rdi) - ret + fnstsw (%rdi) + fnstcw 2(%rdi) + ret DEF(void,set_x87_env,(const void*)): - fnclex - fldcw 2(%rdi) - ret + fnclex + fldcw 2(%rdi) + ret #include "cpu-x86.S" diff --git a/vm/cpu-x86.S b/vm/cpu-x86.S index 09e742bed8..d229b2cb79 100644 --- a/vm/cpu-x86.S +++ b/vm/cpu-x86.S @@ -1,38 +1,38 @@ DEF(void,primitive_fixnum_add,(void)): - mov (DS_REG),ARG0 - mov -CELL_SIZE(DS_REG),ARG1 - sub $CELL_SIZE,DS_REG - mov ARG1,ARITH_TEMP_1 - add ARG0,ARITH_TEMP_1 - jo MANGLE(overflow_fixnum_add) - mov ARITH_TEMP_1,(DS_REG) - ret + mov (DS_REG),ARG0 + mov -CELL_SIZE(DS_REG),ARG1 + sub $CELL_SIZE,DS_REG + mov ARG1,ARITH_TEMP_1 + add ARG0,ARITH_TEMP_1 + jo MANGLE(overflow_fixnum_add) + mov ARITH_TEMP_1,(DS_REG) + ret DEF(void,primitive_fixnum_subtract,(void)): - mov (DS_REG),ARG1 - mov -CELL_SIZE(DS_REG),ARG0 - sub $CELL_SIZE,DS_REG - mov ARG0,ARITH_TEMP_1 - sub ARG1,ARITH_TEMP_1 - jo MANGLE(overflow_fixnum_subtract) - mov ARITH_TEMP_1,(DS_REG) - ret + mov (DS_REG),ARG1 + mov -CELL_SIZE(DS_REG),ARG0 + sub $CELL_SIZE,DS_REG + mov ARG0,ARITH_TEMP_1 + sub ARG1,ARITH_TEMP_1 + jo MANGLE(overflow_fixnum_subtract) + mov ARITH_TEMP_1,(DS_REG) + ret DEF(void,primitive_fixnum_multiply,(void)): - mov (DS_REG),ARITH_TEMP_1 - mov ARITH_TEMP_1,DIV_RESULT - mov -CELL_SIZE(DS_REG),ARITH_TEMP_2 - sar $3,ARITH_TEMP_2 - sub $CELL_SIZE,DS_REG - imul ARITH_TEMP_2 - jo multiply_overflow - mov DIV_RESULT,(DS_REG) - ret + mov (DS_REG),ARITH_TEMP_1 + mov ARITH_TEMP_1,DIV_RESULT + mov -CELL_SIZE(DS_REG),ARITH_TEMP_2 + sar $3,ARITH_TEMP_2 + sub $CELL_SIZE,DS_REG + imul ARITH_TEMP_2 + jo multiply_overflow + mov DIV_RESULT,(DS_REG) + ret multiply_overflow: - sar $3,ARITH_TEMP_1 - mov ARITH_TEMP_1,ARG0 - mov ARITH_TEMP_2,ARG1 - jmp MANGLE(overflow_fixnum_multiply) + sar $3,ARITH_TEMP_1 + mov ARITH_TEMP_1,ARG0 + mov ARITH_TEMP_2,ARG1 + jmp MANGLE(overflow_fixnum_multiply) DEF(F_FASTCALL void,c_to_factor,(CELL quot)): PUSH_NONVOLATILE @@ -77,38 +77,38 @@ DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)): DEF(bool,sse_version,(void)): mov $0x1,RETURN_REG cpuid - /* test $0x100000,%ecx - jnz sse_42 - test $0x80000,%ecx - jnz sse_41 - test $0x200,%ecx - jnz ssse_3 */ - test $0x1,%ecx - jnz sse_3 - test $0x4000000,%edx - jnz sse_2 - test $0x2000000,%edx - jnz sse_1 - mov $0,%eax - ret + /* test $0x100000,%ecx + jnz sse_42 + test $0x80000,%ecx + jnz sse_41 + test $0x200,%ecx + jnz ssse_3 */ + test $0x1,%ecx + jnz sse_3 + test $0x4000000,%edx + jnz sse_2 + test $0x2000000,%edx + jnz sse_1 + mov $0,%eax + ret sse_42: - mov $42,RETURN_REG - ret + mov $42,RETURN_REG + ret sse_41: - mov $41,RETURN_REG - ret + mov $41,RETURN_REG + ret ssse_3: - mov $33,RETURN_REG - ret + mov $33,RETURN_REG + ret sse_3: - mov $30,RETURN_REG - ret + mov $30,RETURN_REG + ret sse_2: - mov $20,RETURN_REG - ret + mov $20,RETURN_REG + ret sse_1: - mov $10,RETURN_REG - ret + mov $10,RETURN_REG + ret #ifdef WINDOWS .section .drectve .ascii " -export:sse_version" From d0652d9d0bf98ccd5edad2df91a2db0451e87727 Mon Sep 17 00:00:00 2001 From: Keith Lazuka Date: Mon, 14 Sep 2009 08:50:58 -0400 Subject: [PATCH 27/45] help.stylesheet: fixed black border bug around nav links in HTML documentation --- basis/help/stylesheet/stylesheet.factor | 4 ++-- word-at,assocs.html | 13 +++++++++++++ 2 files changed, 15 insertions(+), 2 deletions(-) create mode 100644 word-at,assocs.html diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor index 2475fba0f6..88fe81de6e 100644 --- a/basis/help/stylesheet/stylesheet.factor +++ b/basis/help/stylesheet/stylesheet.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: colors colors.constants io.styles literals namespaces ; +USING: colors colors.constants io.styles namespaces ; IN: help.stylesheet SYMBOL: default-span-style @@ -42,7 +42,7 @@ SYMBOL: help-path-style H{ { font-size 10 } { table-gap { 5 5 } } - { table-border $ transparent } + { table-border COLOR: FactorLightLightTan } } help-path-style set-global SYMBOL: heading-style diff --git a/word-at,assocs.html b/word-at,assocs.html new file mode 100644 index 0000000000..f0be85855a --- /dev/null +++ b/word-at,assocs.html @@ -0,0 +1,13 @@ + + + + + at ( key assoc -- value/f ) + + +
Vocabulary
assocs

Inputs and outputs
keyan object
assocan assoc
value/fthe value associated to the key, or f if the key is not present in the assoc


Word description
Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to f; if the difference is important, use at*.

See also
at*, key?, ?at

Definition
: at ( key assoc -- value/f ) at* drop ; inline

+ \ No newline at end of file From 91c7eb9eea9366c59762dcb942ff3627730effdb Mon Sep 17 00:00:00 2001 From: Keith Lazuka Date: Mon, 14 Sep 2009 09:01:03 -0400 Subject: [PATCH 28/45] Renamed a Factor theme color to something more sensible. --- basis/colors/constants/factor-colors.txt | 4 ++-- basis/help/stylesheet/stylesheet.factor | 8 ++++---- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/colors/constants/factor-colors.txt b/basis/colors/constants/factor-colors.txt index c032aae5c4..b8af9d3949 100644 --- a/basis/colors/constants/factor-colors.txt +++ b/basis/colors/constants/factor-colors.txt @@ -1,6 +1,6 @@ ! Factor UI theme colors -243 242 234 FactorLightLightTan -227 226 219 FactorLightTan +243 242 234 FactorLightTan +227 226 219 FactorTan 172 167 147 FactorDarkTan 81 91 105 FactorLightSlateBlue 55 62 72 FactorDarkSlateBlue diff --git a/basis/help/stylesheet/stylesheet.factor b/basis/help/stylesheet/stylesheet.factor index 88fe81de6e..8a119823cc 100644 --- a/basis/help/stylesheet/stylesheet.factor +++ b/basis/help/stylesheet/stylesheet.factor @@ -34,7 +34,7 @@ H{ { font-style bold } { wrap-margin 500 } { foreground COLOR: gray20 } - { page-color COLOR: FactorLightLightTan } + { page-color COLOR: FactorLightTan } { inset { 5 5 } } } title-style set-global @@ -42,7 +42,7 @@ SYMBOL: help-path-style H{ { font-size 10 } { table-gap { 5 5 } } - { table-border COLOR: FactorLightLightTan } + { table-border COLOR: FactorLightTan } } help-path-style set-global SYMBOL: heading-style @@ -75,7 +75,7 @@ H{ SYMBOL: code-style H{ - { page-color COLOR: FactorLightLightTan } + { page-color COLOR: FactorLightTan } { inset { 5 5 } } { wrap-margin f } } code-style set-global @@ -113,7 +113,7 @@ H{ SYMBOL: table-style H{ { table-gap { 5 5 } } - { table-border COLOR: FactorLightTan } + { table-border COLOR: FactorTan } } table-style set-global SYMBOL: list-style From 6ae07e8a087f8491cfb714b9c8039159991601d5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 09:48:32 -0500 Subject: [PATCH 29/45] fix compilation on linux 32 --- vm/os-linux-x86.32.hpp | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/vm/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp index e4fd8402a8..1db87f995d 100644 --- a/vm/os-linux-x86.32.hpp +++ b/vm/os-linux-x86.32.hpp @@ -5,22 +5,21 @@ namespace factor inline static void *ucontext_stack_pointer(void *uap) { - ucontext_t *ucontext = (ucontext_t *)uap; - return (void *)ucontext->uc_mcontext.gregs[7]; + ucontext_t *ucontext = (ucontext_t *)uap; + return (void *)ucontext->uc_mcontext.gregs[7]; } inline static unsigned int uap_fpu_status(void *uap) { - ucontext_t *ucontext = (ucontext_t *)uap; - return ucontext->uc_mcontext.fpregs->swd - | ucontext->uc_mcontext.fpregs->mxcsr; + // XXX mxcsr not available in i386 ucontext + ucontext_t *ucontext = (ucontext_t *)uap; + return ucontext->uc_mcontext.fpregs->sw; } inline static void uap_clear_fpu_status(void *uap) { - ucontext_t *ucontext = (ucontext_t *)uap; - ucontext->uc_mcontext.fpregs->swd = 0; - ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0; + ucontext_t *ucontext = (ucontext_t *)uap; + ucontext->uc_mcontext.fpregs->sw = 0; } #define UAP_PROGRAM_COUNTER(ucontext) \ From 578c977a7e8447a444a36223f27f62f3f61d68e8 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 09:56:38 -0500 Subject: [PATCH 30/45] more freebsd compilation fixes --- vm/os-freebsd-x86.32.hpp | 4 ++-- vm/os-freebsd-x86.64.hpp | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/vm/os-freebsd-x86.32.hpp b/vm/os-freebsd-x86.32.hpp index a0888e1f5b..e682fec13c 100644 --- a/vm/os-freebsd-x86.32.hpp +++ b/vm/os-freebsd-x86.32.hpp @@ -30,12 +30,12 @@ inline static unsigned int uap_fpu_status(void *uap) inline static void uap_clear_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_387) + if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387) { struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate); x87->sv_env.en_sw = 0; } - else if (uap->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) + else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); xmm->sv_env.en_sw = 0; diff --git a/vm/os-freebsd-x86.64.hpp b/vm/os-freebsd-x86.64.hpp index 6200a0f5f3..8f8d218a10 100644 --- a/vm/os-freebsd-x86.64.hpp +++ b/vm/os-freebsd-x86.64.hpp @@ -15,7 +15,7 @@ inline static unsigned int uap_fpu_status(void *uap) ucontext_t *ucontext = (ucontext_t *)uap; if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { - struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate); return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr; } else @@ -27,7 +27,7 @@ inline static void uap_clear_fpu_status(void *uap) ucontext_t *ucontext = (ucontext_t *)uap; if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM) { - struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate); + struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate); xmm->sv_env.en_sw = 0; xmm->sv_env.en_mxcsr &= 0xffffffc0; } From fad3d47a8b05c358b5b07041f1dc79674411b226 Mon Sep 17 00:00:00 2001 From: Keith Lazuka Date: Mon, 14 Sep 2009 11:13:45 -0400 Subject: [PATCH 31/45] help.vocabs: inform the user when browsing a vocab that is not loaded. --- basis/help/vocabs/vocabs.factor | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index e8b145d37e..a7cd70707d 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -227,6 +227,15 @@ C: vocab-author ] bi ] unless-empty ; +: vocab-is-not-loaded ( vocab -- ) + "Attention" $heading + vocab-name dup "The " " vocabulary is not loaded. In order to browse " + "its documentation, you must first load it." append surround print-element + "USE: " prepend 1array $code ; + +: describe-words ( vocab -- ) + dup vocab [ words $words ] [ vocab-is-not-loaded ] if ; + : words. ( vocab -- ) last-element off [ require ] [ words $words ] bi nl ; @@ -243,7 +252,7 @@ C: vocab-author first { [ describe-help ] [ describe-metadata ] - [ words $words ] + [ describe-words ] [ describe-files ] [ describe-children ] } cleave ; From c1bc5f22e46e11e3cfd1781141611512e4a39e6e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 12:02:02 -0500 Subject: [PATCH 32/45] use secret sauce to clear MXCSR in win32 context, and handle secret STATUS_FLOAT_MULTIPLE_* SEH codes raised by SSE traps --- vm/os-windows-nt.32.hpp | 29 +++++++++++++++++++++++++++++ vm/os-windows-nt.64.hpp | 3 +++ vm/os-windows-nt.cpp | 22 ++++++++++++---------- vm/os-windows-nt.hpp | 5 +++++ 4 files changed, 49 insertions(+), 10 deletions(-) mode change 100644 => 100755 vm/os-windows-nt.32.hpp mode change 100644 => 100755 vm/os-windows-nt.64.hpp mode change 100644 => 100755 vm/os-windows-nt.cpp mode change 100644 => 100755 vm/os-windows-nt.hpp diff --git a/vm/os-windows-nt.32.hpp b/vm/os-windows-nt.32.hpp old mode 100644 new mode 100755 index ed67e28b8b..748272ff38 --- a/vm/os-windows-nt.32.hpp +++ b/vm/os-windows-nt.32.hpp @@ -4,4 +4,33 @@ namespace factor #define ESP Esp #define EIP Eip +typedef struct DECLSPEC_ALIGN(16) _M128A { + ULONGLONG Low; + LONGLONG High; +} M128A, *PM128A; + +/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however, + * this structure is only made available from winnt.h on x86.64 */ +typedef struct _XMM_SAVE_AREA32 { + WORD ControlWord; /* 000 */ + WORD StatusWord; /* 002 */ + BYTE TagWord; /* 004 */ + BYTE Reserved1; /* 005 */ + WORD ErrorOpcode; /* 006 */ + DWORD ErrorOffset; /* 008 */ + WORD ErrorSelector; /* 00c */ + WORD Reserved2; /* 00e */ + DWORD DataOffset; /* 010 */ + WORD DataSelector; /* 014 */ + WORD Reserved3; /* 016 */ + DWORD MxCsr; /* 018 */ + DWORD MxCsr_Mask; /* 01c */ + M128A FloatRegisters[8]; /* 020 */ + M128A XmmRegisters[16]; /* 0a0 */ + BYTE Reserved4[96]; /* 1a0 */ +} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32; + +#define X87SW(ctx) (ctx)->FloatSave.StatusWord +#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr + } diff --git a/vm/os-windows-nt.64.hpp b/vm/os-windows-nt.64.hpp old mode 100644 new mode 100755 index 30ce150754..b64bd607cb --- a/vm/os-windows-nt.64.hpp +++ b/vm/os-windows-nt.64.hpp @@ -4,4 +4,7 @@ namespace factor #define ESP Rsp #define EIP Rip +#define X87SW(ctx) (ctx)->FloatSave.StatusWord +#define MXCSR(ctx) (ctx)->MxCsr + } diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp old mode 100644 new mode 100755 index 017a96bb7c..b50c9b7af8 --- a/vm/os-windows-nt.cpp +++ b/vm/os-windows-nt.cpp @@ -28,16 +28,18 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe) c->EIP = (cell)memory_signal_handler_impl; break; - case EXCEPTION_FLT_DENORMAL_OPERAND: - case EXCEPTION_FLT_DIVIDE_BY_ZERO: - case EXCEPTION_FLT_INEXACT_RESULT: - case EXCEPTION_FLT_INVALID_OPERATION: - case EXCEPTION_FLT_OVERFLOW: - case EXCEPTION_FLT_STACK_CHECK: - case EXCEPTION_FLT_UNDERFLOW: - /* XXX MxCsr is not available in CONTEXT structure on x86.32 */ - signal_fpu_status = c->FloatSave.StatusWord; - c->FloatSave.StatusWord = 0; + case STATUS_FLOAT_DENORMAL_OPERAND: + case STATUS_FLOAT_DIVIDE_BY_ZERO: + case STATUS_FLOAT_INEXACT_RESULT: + case STATUS_FLOAT_INVALID_OPERATION: + case STATUS_FLOAT_OVERFLOW: + case STATUS_FLOAT_STACK_CHECK: + case STATUS_FLOAT_UNDERFLOW: + case STATUS_FLOAT_MULTIPLE_FAULTS: + case STATUS_FLOAT_MULTIPLE_TRAPS: + signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c)); + X87SW(c) = 0; + MXCSR(c) &= 0xffffffc0; c->EIP = (cell)fp_signal_handler_impl; break; case 0x40010006: diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp old mode 100644 new mode 100755 index 4371771c13..088103bb5b --- a/vm/os-windows-nt.hpp +++ b/vm/os-windows-nt.hpp @@ -23,4 +23,9 @@ void c_to_factor_toplevel(cell quot); FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe); void open_console(); +// SSE traps raise these exception codes, which are defined in internal NT headers +// but not winbase.h +#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4 +#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5 + } From b77d9d29608c43d2cb5304343a224cbd0861778c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 12:30:10 -0500 Subject: [PATCH 33/45] more secret sauce to tease mxcsr out of linux-x86.32 ucontext --- vm/os-linux-x86.32.hpp | 38 +++++++++++++++++++++++++++++++++++--- 1 file changed, 35 insertions(+), 3 deletions(-) diff --git a/vm/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp index 1db87f995d..8fa7eff842 100644 --- a/vm/os-linux-x86.32.hpp +++ b/vm/os-linux-x86.32.hpp @@ -3,6 +3,32 @@ namespace factor { +// glibc lies about the contents of the fpstate the kernel provides, hiding the FXSR +// environment +struct _fpstate { + /* Regular FPU environment */ + unsigned long cw; + unsigned long sw; + unsigned long tag; + unsigned long ipoff; + unsigned long cssel; + unsigned long dataoff; + unsigned long datasel; + struct _fpreg _st[8]; + unsigned short status; + unsigned short magic; /* 0xffff = regular FPU data only */ + + /* FXSR FPU environment */ + unsigned long _fxsr_env[6]; /* FXSR FPU env is ignored */ + unsigned long mxcsr; + unsigned long reserved; + struct _fpxreg _fxsr_st[8]; /* FXSR FPU reg data is ignored */ + struct _xmmreg _xmm[8]; + unsigned long padding[56]; +}; + +#define X86_FXSR_MAGIC 0x0000 + inline static void *ucontext_stack_pointer(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; @@ -11,15 +37,21 @@ inline static void *ucontext_stack_pointer(void *uap) inline static unsigned int uap_fpu_status(void *uap) { - // XXX mxcsr not available in i386 ucontext ucontext_t *ucontext = (ucontext_t *)uap; - return ucontext->uc_mcontext.fpregs->sw; + struct _fpstate *fpregs = (struct _fpstate *)uap->uc_mcontext.fpregs; + if (fpregs->magic == X86_FXSR_MAGIC) + return fpregs->sw | fpregs->mxcsr; + else + return fpregs->sw; } inline static void uap_clear_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - ucontext->uc_mcontext.fpregs->sw = 0; + struct _fpstate *fpregs = (struct _fpstate *)uap->uc_mcontext.fpregs; + fpregs->sw = 0; + if (fpregs->magic == X86_FXSR_MAGIC) + fpregs->mxcsr &= 0xffffffc0; } #define UAP_PROGRAM_COUNTER(ucontext) \ From 89ce13d4d46f61b445cd0e9b0aebaebed54d66f0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 13:21:46 -0500 Subject: [PATCH 34/45] linux 32 typo --- vm/os-linux-x86.32.hpp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/vm/os-linux-x86.32.hpp b/vm/os-linux-x86.32.hpp index 8fa7eff842..bd2315ccef 100644 --- a/vm/os-linux-x86.32.hpp +++ b/vm/os-linux-x86.32.hpp @@ -38,7 +38,7 @@ inline static void *ucontext_stack_pointer(void *uap) inline static unsigned int uap_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - struct _fpstate *fpregs = (struct _fpstate *)uap->uc_mcontext.fpregs; + struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs; if (fpregs->magic == X86_FXSR_MAGIC) return fpregs->sw | fpregs->mxcsr; else @@ -48,7 +48,7 @@ inline static unsigned int uap_fpu_status(void *uap) inline static void uap_clear_fpu_status(void *uap) { ucontext_t *ucontext = (ucontext_t *)uap; - struct _fpstate *fpregs = (struct _fpstate *)uap->uc_mcontext.fpregs; + struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs; fpregs->sw = 0; if (fpregs->magic == X86_FXSR_MAGIC) fpregs->mxcsr &= 0xffffffc0; From b6d57a4d19c02f68f5dc2c1d4d243b511baab0f2 Mon Sep 17 00:00:00 2001 From: Keith Lazuka Date: Mon, 14 Sep 2009 14:27:30 -0400 Subject: [PATCH 35/45] help.vocabs: tweaked the vocab-not-loaded msg --- basis/help/vocabs/vocabs.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index a7cd70707d..6e2fd6f278 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -228,10 +228,9 @@ C: vocab-author ] unless-empty ; : vocab-is-not-loaded ( vocab -- ) - "Attention" $heading - vocab-name dup "The " " vocabulary is not loaded. In order to browse " - "its documentation, you must first load it." append surround print-element - "USE: " prepend 1array $code ; + "Words" $heading + "You must first load (USE:) this vocab to browse its documentation/words." + print-element vocab-name "USE: " prepend 1array $code ; : describe-words ( vocab -- ) dup vocab [ words $words ] [ vocab-is-not-loaded ] if ; From 79505168cfddd38d01ae307529c1af7b1b3b9af9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 14 Sep 2009 13:47:37 -0500 Subject: [PATCH 36/45] faster number-length and some unit tests --- extra/project-euler/common/common-tests.factor | 17 +++++++++++++++++ extra/project-euler/common/common.factor | 7 ++++++- 2 files changed, 23 insertions(+), 1 deletion(-) create mode 100644 extra/project-euler/common/common-tests.factor diff --git a/extra/project-euler/common/common-tests.factor b/extra/project-euler/common/common-tests.factor new file mode 100644 index 0000000000..1f7a3668e2 --- /dev/null +++ b/extra/project-euler/common/common-tests.factor @@ -0,0 +1,17 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test project-euler.common ; +IN: project-euler.common.tests + +[ 4 ] [ -1000 number-length ] unit-test +[ 3 ] [ -999 number-length ] unit-test +[ 3 ] [ -100 number-length ] unit-test +[ 2 ] [ -99 number-length ] unit-test +[ 1 ] [ -9 number-length ] unit-test +[ 1 ] [ -1 number-length ] unit-test +[ 1 ] [ 0 number-length ] unit-test +[ 1 ] [ 9 number-length ] unit-test +[ 2 ] [ 99 number-length ] unit-test +[ 3 ] [ 100 number-length ] unit-test +[ 3 ] [ 999 number-length ] unit-test +[ 4 ] [ 1000 number-length ] unit-test diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index efec77355b..3d320fad62 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -76,7 +76,12 @@ PRIVATE> [ dup 0 = not ] [ 10 /mod ] produce reverse nip ; : number-length ( n -- m ) - log10 floor 1 + >integer ; + abs [ + 1 + ] [ + 1 0 [ 2over >= ] + [ [ 10 * ] [ 1 + ] bi* ] while 2nip + ] if-zero ; : nth-prime ( n -- n ) 1 - lprimes lnth ; From 2fdb16060b8e15c0f9e90da28064241c97ae219d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 14:10:51 -0500 Subject: [PATCH 37/45] vm-error>exception-flags word to extract exception flag information from a trap exception --- basis/math/floats/env/env-docs.factor | 20 +++++++++++++++----- basis/math/floats/env/env.factor | 22 +++++++++++++++++++--- 2 files changed, 34 insertions(+), 8 deletions(-) diff --git a/basis/math/floats/env/env-docs.factor b/basis/math/floats/env/env-docs.factor index ef580b9040..0fc781713c 100644 --- a/basis/math/floats/env/env-docs.factor +++ b/basis/math/floats/env/env-docs.factor @@ -1,5 +1,5 @@ ! (c)Joe Groff bsd license -USING: help help.markup help.syntax quotations ; +USING: help help.markup help.syntax kernel quotations ; IN: math.floats.env HELP: fp-exception @@ -97,13 +97,21 @@ HELP: fp-traps HELP: with-fp-traps { $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } } -{ $description "Replaces the floating-point exception mask to enable processor traps to be raised for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ; +{ $description "Clears the floating-point exception flags and replaces the exception mask, enabling processor traps for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ". The original exception mask is restored on " { $snippet "quot" } "'s completion." } ; HELP: without-fp-traps { $values { "quot" quotation } } { $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ; -{ fp-traps with-fp-traps without-fp-traps } related-words +{ fp-traps with-fp-traps without-fp-traps vm-error>exception-flags vm-error-exception-flag? } related-words + +HELP: vm-error>exception-flags +{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } } +{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word extracts the exception flag information from " { $snippet "error" } " and converts it into a sequence of " { $link fp-exception } "s." } ; + +HELP: vm-error-exception-flag? +{ $values { "error" "a floating-point error object from the Factor VM" } { "flag" fp-exception } { "?" boolean } } +{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word returns a boolean indicating whether the exception " { $snippet "flag" } " was raised at the time " { $snippet "error" } " was thrown." } ; ARTICLE: "math.floats.env" "Controlling the floating-point environment" "The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment." @@ -117,11 +125,13 @@ $nl { $subsection fp-traps } { $subsection with-fp-traps } { $subsection without-fp-traps } +"Getting the floating-point exception state from errors raised by enabled traps:" +{ $subsection vm-error>exception-flags } +{ $subsection vm-error-exception-flag? } "Querying and controlling the rounding mode and treatment of denormals:" { $subsection rounding-mode } { $subsection with-rounding-mode } { $subsection denormal-mode } -{ $subsection with-denormal-mode } -{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ; +{ $subsection with-denormal-mode } ; ABOUT: "math.floats.env" diff --git a/basis/math/floats/env/env.factor b/basis/math/floats/env/env.factor index 0b1267eb32..04fbc4f26c 100644 --- a/basis/math/floats/env/env.factor +++ b/basis/math/floats/env/env.factor @@ -1,7 +1,8 @@ ! (c)Joe Groff bsd license -USING: alien.syntax arrays assocs biassocs combinators continuations -generalizations kernel literals locals math math.bitwise -sequences sets system vocabs.loader ; +USING: alien.syntax arrays assocs biassocs combinators +combinators.short-circuit continuations generalizations kernel +literals locals math math.bitwise sequences sets system +vocabs.loader ; IN: math.floats.env SINGLETONS: @@ -102,6 +103,15 @@ GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env ) } spread ] 4 ncurry change-fp-env-registers ; +CONSTANT: vm-error-exception-flag>bit + H{ + { +fp-invalid-operation+ HEX: 01 } + { +fp-overflow+ HEX: 02 } + { +fp-underflow+ HEX: 04 } + { +fp-zero-divide+ HEX: 08 } + { +fp-inexact+ HEX: 10 } + } + PRIVATE> : fp-exception-flags ( -- exceptions ) @@ -113,6 +123,11 @@ PRIVATE> : collect-fp-exceptions ( quot -- exceptions ) [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline +: vm-error>exception-flags ( error -- exceptions ) + third vm-error-exception-flag>bit mask> ; +: vm-error-exception-flag? ( error flag -- ? ) + vm-error>exception-flags member? ; + : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ; :: with-denormal-mode ( mode quot -- ) @@ -131,6 +146,7 @@ PRIVATE> (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline :: with-fp-traps ( exceptions quot -- ) + clear-fp-exception-flags fp-traps :> orig exceptions set-fp-traps quot [ orig set-fp-traps ] [ ] cleanup ; inline From 8c14af3f6c8ed0a6bf5e0d2c6f89b94fd12abb78 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 15:03:05 -0500 Subject: [PATCH 38/45] add a number-base configuration variable to prettyprint.config. set to 2 to print BIN:, 8 to print OCT:, 10 to print decimal, 16 to print HEX: --- basis/prettyprint/backend/backend.factor | 15 +++++++++++++-- basis/prettyprint/config/config.factor | 2 ++ basis/prettyprint/prettyprint-tests.factor | 8 ++++++++ core/math/parser/parser.factor | 6 ++---- 4 files changed, 25 insertions(+), 6 deletions(-) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index f8bcb66b1e..cba40bbff1 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -45,12 +45,23 @@ M: method-body pprint* ] "" make ] [ word-style ] bi styled-text ; -M: real pprint* number>string text ; +M: real pprint* + number-base get { + { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] } + { 8 [ \ OCT: [ 8 >base text ] pprint-prefix ] } + { 2 [ \ BIN: [ 2 >base text ] pprint-prefix ] } + [ drop number>string text ] + } case ; M: float pprint* dup fp-nan? [ \ NAN: [ fp-nan-payload >hex text ] pprint-prefix - ] [ call-next-method ] if ; + ] [ + number-base get { + { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] } + [ drop number>string text ] + } case + ] if ; M: f pprint* drop \ f pprint-word ; diff --git a/basis/prettyprint/config/config.factor b/basis/prettyprint/config/config.factor index d42b134d4c..45557925a5 100644 --- a/basis/prettyprint/config/config.factor +++ b/basis/prettyprint/config/config.factor @@ -11,9 +11,11 @@ SYMBOL: margin SYMBOL: nesting-limit SYMBOL: length-limit SYMBOL: line-limit +SYMBOL: number-base SYMBOL: string-limit? SYMBOL: boa-tuples? SYMBOL: c-object-pointers? 4 tab-size set-global 64 margin set-global +10 number-base set-global diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index b3897960f0..db3331305e 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -8,7 +8,15 @@ listener ; IN: prettyprint.tests [ "4" ] [ 4 unparse ] unit-test +[ "4096" ] [ 4096 unparse ] unit-test +[ "BIN: 1000000000000" ] [ 2 number-base [ 4096 unparse ] with-variable ] unit-test +[ "OCT: 10000" ] [ 8 number-base [ 4096 unparse ] with-variable ] unit-test +[ "HEX: 1000" ] [ 16 number-base [ 4096 unparse ] with-variable ] unit-test [ "1.0" ] [ 1.0 unparse ] unit-test +[ "8.0" ] [ 8.0 unparse ] unit-test +[ "8.0" ] [ 2 number-base [ 8.0 unparse ] with-variable ] unit-test +[ "8.0" ] [ 8 number-base [ 8.0 unparse ] with-variable ] unit-test +[ "HEX: 1.0p3" ] [ 16 number-base [ 8.0 unparse ] with-variable ] unit-test [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test [ "+" ] [ \ + unparse ] unit-test diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 8e911453ad..d422a2c199 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -109,9 +109,8 @@ SYMBOL: negative? : base>float ( str base -- n/f ) { - { 10 [ dec>float ] } { 16 [ hex>float ] } - [ "Floats can only be converted from strings in base 10 or 16" throw ] + [ drop dec>float ] } case ; : number-char? ( char -- ? ) @@ -232,9 +231,8 @@ M: ratio >base : float>base ( n base -- str ) { - { 10 [ float>decimal ] } { 16 [ float>hex ] } - [ "Floats can only be converted to strings in base 10 or 16" throw ] + [ drop float>decimal ] } case ; PRIVATE> From 77f0fbf497a37d03d9a0a648fd6b47ed0b5b843a Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 14 Sep 2009 15:17:36 -0500 Subject: [PATCH 39/45] missed a few PPC status bits that needed clearing --- basis/math/floats/env/ppc/ppc.factor | 2 +- vm/os-macosx-ppc.hpp | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/math/floats/env/ppc/ppc.factor b/basis/math/floats/env/ppc/ppc.factor index dd8fd88b13..d6a6ae6834 100644 --- a/basis/math/floats/env/ppc/ppc.factor +++ b/basis/math/floats/env/ppc/ppc.factor @@ -34,7 +34,7 @@ M: ppc-vmx-env (set-fp-env-register) M: ppc (fp-env-registers) 2array ; -CONSTANT: ppc-exception-flag-bits HEX: fff8,0000 +CONSTANT: ppc-exception-flag-bits HEX: fff8,0700 CONSTANT: ppc-exception-flag>bit H{ { +fp-invalid-operation+ HEX: 2000,0000 } diff --git a/vm/os-macosx-ppc.hpp b/vm/os-macosx-ppc.hpp index 338e3e812f..cd2097a3fd 100644 --- a/vm/os-macosx-ppc.hpp +++ b/vm/os-macosx-ppc.hpp @@ -69,7 +69,7 @@ inline static cell fix_stack_pointer(cell sp) inline static void mach_clear_fpu_status(ppc_float_state_t *float_state) { - FPSCR(float_state) &= 0x0007ffff; + FPSCR(float_state) &= 0x0007f8ff; } inline static void uap_clear_fpu_status(void *uap) From 111d298cea146a2f723e0090d6c5d4a345323d53 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 16:14:53 -0500 Subject: [PATCH 40/45] Remove bogus file --- word-at,assocs.html | 13 ------------- 1 file changed, 13 deletions(-) delete mode 100644 word-at,assocs.html diff --git a/word-at,assocs.html b/word-at,assocs.html deleted file mode 100644 index f0be85855a..0000000000 --- a/word-at,assocs.html +++ /dev/null @@ -1,13 +0,0 @@ - - - - - at ( key assoc -- value/f ) - - -
Vocabulary
assocs

Inputs and outputs
keyan object
assocan assoc
value/fthe value associated to the key, or f if the key is not present in the assoc


Word description
Looks up the value associated with a key. This word makes no distinction between a missing value and a value set to f; if the difference is important, use at*.

See also
at*, key?, ?at

Definition
: at ( key assoc -- value/f ) at* drop ; inline

- \ No newline at end of file From d772bff8b903d379f474b1790fd94d17853791ce Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 16:19:36 -0500 Subject: [PATCH 41/45] help.vocabs: tweak 'not loaded' message some more --- basis/help/vocabs/vocabs.factor | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/basis/help/vocabs/vocabs.factor b/basis/help/vocabs/vocabs.factor index 6e2fd6f278..d8f351f57d 100644 --- a/basis/help/vocabs/vocabs.factor +++ b/basis/help/vocabs/vocabs.factor @@ -228,12 +228,16 @@ C: vocab-author ] unless-empty ; : vocab-is-not-loaded ( vocab -- ) - "Words" $heading - "You must first load (USE:) this vocab to browse its documentation/words." + "Not loaded" $heading + "You must first load this vocabulary to browse its documentation and words." print-element vocab-name "USE: " prepend 1array $code ; : describe-words ( vocab -- ) - dup vocab [ words $words ] [ vocab-is-not-loaded ] if ; + { + { [ dup vocab ] [ words $words ] } + { [ dup find-vocab-root ] [ vocab-is-not-loaded ] } + [ drop ] + } cond ; : words. ( vocab -- ) last-element off From 4f702de449ba65d4c9f813e8b74e77471e7066aa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 16:19:58 -0500 Subject: [PATCH 42/45] math.functions: more accurate log10 (fixes problem reported by OneEyed) --- basis/compiler/cfg/intrinsics/intrinsics.factor | 1 + basis/math/functions/functions-tests.factor | 6 ++++++ basis/math/functions/functions.factor | 6 +++++- basis/math/libm/libm.factor | 3 +++ 4 files changed, 15 insertions(+), 1 deletion(-) diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index a54caf23de..0daab82395 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -129,6 +129,7 @@ IN: compiler.cfg.intrinsics { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] } { math.libm:fexp [ drop "exp" emit-unary-float-function ] } { math.libm:flog [ drop "log" emit-unary-float-function ] } + { math.libm:flog10 [ drop "log10" emit-unary-float-function ] } { math.libm:fpow [ drop "pow" emit-binary-float-function ] } { math.libm:facosh [ drop "acosh" emit-unary-float-function ] } { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] } diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 7a6da72005..fa880f77af 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -33,6 +33,12 @@ IN: math.functions.tests [ 0.0 ] [ 1.0 log ] unit-test [ 1.0 ] [ e log ] unit-test +[ 0.0 ] [ 1.0 log10 ] unit-test +[ 1.0 ] [ 10.0 log10 ] unit-test +[ 2.0 ] [ 100.0 log10 ] unit-test +[ 3.0 ] [ 1000.0 log10 ] unit-test +[ 4.0 ] [ 10000.0 log10 ] unit-test + [ t ] [ 1 exp e 1.e-10 ~ ] unit-test [ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test [ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 0cf9467795..f124c202b8 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -173,7 +173,11 @@ M: float log1+ dup -1.0 >= [ flog1+ ] [ 1.0 + 0.0 rect> log ] if ; inline : 10^ ( x -- y ) 10 swap ^ ; inline -: log10 ( x -- y ) log 10 log / ; inline +GENERIC: log10 ( x -- y ) foldable + +M: real log10 >float flog10 ; inline + +M: complex log10 log 10 log / ; inline GENERIC: cos ( x -- y ) foldable diff --git a/basis/math/libm/libm.factor b/basis/math/libm/libm.factor index 1ac0ec0ae7..df8b36fd28 100644 --- a/basis/math/libm/libm.factor +++ b/basis/math/libm/libm.factor @@ -39,6 +39,9 @@ IN: math.libm : flog ( x -- y ) "double" "libm" "log" { "double" } alien-invoke ; +: flog10 ( x -- y ) + "double" "libm" "log10" { "double" } alien-invoke ; + : fpow ( x y -- z ) "double" "libm" "pow" { "double" "double" } alien-invoke ; From ded68c67c03c11b9187023df9b10e98f3cb69e9d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 20:26:59 -0500 Subject: [PATCH 43/45] Fix bootstrap --- basis/prettyprint/config/config.factor | 2 +- basis/vocabs/prettyprint/prettyprint.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/prettyprint/config/config.factor b/basis/prettyprint/config/config.factor index 45557925a5..dd61e3e23d 100644 --- a/basis/prettyprint/config/config.factor +++ b/basis/prettyprint/config/config.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic assocs io kernel math -namespaces sequences strings io.styles vectors words +namespaces sequences strings vectors words continuations ; IN: prettyprint.config diff --git a/basis/vocabs/prettyprint/prettyprint.factor b/basis/vocabs/prettyprint/prettyprint.factor index 6b759dddde..40493e4e99 100644 --- a/basis/vocabs/prettyprint/prettyprint.factor +++ b/basis/vocabs/prettyprint/prettyprint.factor @@ -88,7 +88,7 @@ PRIVATE> "at the top of the source file:" print nl ] with-style { - { page-color COLOR: FactorLightLightTan } + { page-color COLOR: FactorLightTan } { border-color COLOR: FactorDarkTan } { inset { 5 5 } } } [ manifest get pprint-manifest ] with-nesting From 05fe9c7eadbab785dfdb46b873d9d797effd076a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 14 Sep 2009 21:03:33 -0500 Subject: [PATCH 44/45] colors.constants: clean up naming --- basis/colors/constants/constants.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor index 3912994066..8598fc0663 100644 --- a/basis/colors/constants/constants.factor +++ b/basis/colors/constants/constants.factor @@ -11,23 +11,23 @@ IN: colors.constants [ [ string>number 255 /f ] tri@ 1.0 ] dip [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ; -: parse-rgb.txt ( lines -- assoc ) +: parse-colors ( lines -- assoc ) [ "!" head? not ] filter [ 11 cut [ " \t" split harvest ] dip suffix ] map [ parse-color ] H{ } map>assoc ; -MEMO: rgb.txt ( -- assoc ) +MEMO: colors ( -- assoc ) "resource:basis/colors/constants/rgb.txt" "resource:basis/colors/constants/factor-colors.txt" - [ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ; + [ utf8 file-lines parse-colors ] bi@ assoc-union ; PRIVATE> -: named-colors ( -- keys ) rgb.txt keys ; +: named-colors ( -- keys ) colors keys ; ERROR: no-such-color name ; : named-color ( name -- color ) - dup rgb.txt at [ ] [ no-such-color ] ?if ; + dup colors at [ ] [ no-such-color ] ?if ; SYNTAX: COLOR: scan named-color parsed ; \ No newline at end of file From 3551294fd42cff1e7ea1baf195f4118e10cee735 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 15 Sep 2009 00:22:19 -0500 Subject: [PATCH 45/45] vm: update Config.netbsd for NetBSD 5.0 --- vm/Config.netbsd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/Config.netbsd b/vm/Config.netbsd index a6ec997ecd..ba5ecd19a5 100644 --- a/vm/Config.netbsd +++ b/vm/Config.netbsd @@ -1,5 +1,5 @@ include vm/Config.unix PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o CFLAGS += -export-dynamic -LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib +LIBPATH = -L/usr/X11R7/lib -Wl,-rpath,/usr/X11R7/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib LIBS = -lm -lssl -lcrypto $(X11_UI_LIBS)