: primitive-error. ( error -- )
"Unimplemented primitive" print drop ;
+: fp-trap-error. ( error -- )
+ "Floating point trap" print drop ;
+
PREDICATE: vm-error < array
{
{ [ dup empty? ] [ drop f ] }
{ [ dup first "kernel-error" = not ] [ drop f ] }
- [ second 0 15 between? ]
+ [ second 0 16 between? ]
} cond ;
: vm-errors ( error -- n errors )
{ 13 [ retainstack-underflow. ] }
{ 14 [ retainstack-overflow. ] }
{ 15 [ memory-error. ] }
+ { 16 [ fp-trap-error. ] }
} ; inline
M: vm-error summary drop "VM error" ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: help help.markup help.syntax quotations ;
+IN: math.floats.env
+
+HELP: fp-exception
+{ $class-description "Symbols of this type represent floating-point exceptions. They are used to get and set the floating-point unit's exception flags (using " { $link fp-exception-flags } " and " { $link set-fp-exception-flags } ") and to control processor traps (using " { $link with-fp-traps } "). The following symbols are defined:"
+{ $list
+{ { $link +fp-invalid-operation+ } " indicates that an invalid floating-point operation occurred, such as taking the square root of a negative number or dividing zero by zero." }
+{ { $link +fp-overflow+ } " indicates that a floating-point operation gave a result larger than the maximum representable value of the type used to perform the calculation." }
+{ { $link +fp-underflow+ } " indicates that a floating-point operation gave a result smaller than the minimum representable normalized value of the type used to perform the calculation." }
+{ { $link +fp-zero-divide+ } " indicates that a floating-point division by zero was attempted." }
+{ { $link +fp-inexact+ } " indicates that a floating-point operation gave an inexact result that needed to be rounded." }
+} } ;
+
+HELP: +fp-invalid-operation+
+{ $class-description "This symbol represents a invalid operation " { $link fp-exception } "." } ;
+HELP: +fp-overflow+
+{ $class-description "This symbol represents an overflow " { $link fp-exception } "." } ;
+HELP: +fp-underflow+
+{ $class-description "This symbol represents an underflow " { $link fp-exception } "." } ;
+HELP: +fp-zero-divide+
+{ $class-description "This symbol represents a division-by-zero " { $link fp-exception } "." } ;
+HELP: +fp-inexact+
+{ $class-description "This symbol represents an inexact result " { $link fp-exception } "." } ;
+
+HELP: fp-rounding-mode
+{ $class-description "Symbols of this type represent floating-point rounding modes. They are passed to the " { $link with-rounding-mode } " word to control how inexact values are calculated when exact results cannot fit in a floating-point type. The following symbols are defined:"
+{ $list
+{ { $link +round-nearest+ } " rounds the exact result to the nearest representable value, using the even value when the result is halfway between its two nearest values." }
+{ { $link +round-zero+ } " rounds the exact result toward zero, that is, down for positive values, and up for negative values." }
+{ { $link +round-down+ } " always rounds the exact result down." }
+{ { $link +round-up+ } " always rounds the exact result up." }
+} } ;
+
+HELP: +round-nearest+
+{ $class-description "This symbol represents the round-to-nearest " { $link fp-rounding-mode } "." } ;
+HELP: +round-zero+
+{ $class-description "This symbol represents the round-toward-zero " { $link fp-rounding-mode } "." } ;
+HELP: +round-down+
+{ $class-description "This symbol represents the round-down " { $link fp-rounding-mode } "." } ;
+HELP: +round-up+
+{ $class-description "This symbol represents the round-up " { $link fp-rounding-mode } "." } ;
+
+HELP: fp-denormal-mode
+{ $class-description "Symbols of this type represent floating-point denormal modes. They are passed to the " { $link with-denormal-mode } " word to control whether denormals are generated as outputs of floating-point operations and how they are treated when given as inputs."
+{ $list
+{ { $link +denormal-keep+ } " causes denormal results to be generated and accepted as inputs as required by IEEE 754." }
+{ { $link +denormal-flush+ } " causes denormal results to be flushed to zero and be treated as zero when given as inputs. This mode may allow floating point operations to give results that are not compliant with the IEEE 754 standard." }
+} } ;
+
+HELP: +denormal-keep+
+{ $class-description "This symbol represents the IEEE 754 compliant keep-denormals " { $link fp-denormal-mode } "." } ;
+HELP: +denormal-flush+
+{ $class-description "This symbol represents the non-IEEE-754-compliant flush-denormals-to-zero " { $link fp-denormal-mode } "." } ;
+
+HELP: fp-exception-flags
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Returns the set of floating-point exception flags that have been raised." } ;
+
+HELP: set-fp-exception-flags
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Replaces the set of floating-point exception flags with the set specified in " { $snippet "exceptions" } "." }
+{ $notes "On Intel platforms, the legacy x87 floating-point unit does not support setting exception flags, so this word only clears the x87 exception flags. However, the SSE unit's flags are set as expected." } ;
+
+HELP: clear-fp-exception-flags
+{ $description "Clears all of the floating-point exception flags." } ;
+
+HELP: collect-fp-exceptions
+{ $values { "quot" quotation } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Clears the floating-point exception flags and then calls " { $snippet "quot" } ", returning the set of floating-point exceptions raised during its execution and placing them on the datastack on " { $snippet "quot" } "'s completion." } ;
+
+{ fp-exception-flags set-fp-exception-flags clear-fp-exception-flags collect-fp-exceptions } related-words
+
+HELP: denormal-mode
+{ $values { "mode" fp-denormal-mode } }
+{ $description "Returns the current floating-point denormal mode." } ;
+
+HELP: with-denormal-mode
+{ $values { "mode" fp-denormal-mode } { "quot" quotation } }
+{ $description "Sets the floating-point denormal mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the denormal mode to its original value on " { $snippet "quot" } "'s completion." } ;
+
+{ denormal-mode with-denormal-mode } related-words
+
+HELP: rounding-mode
+{ $values { "mode" fp-rounding-mode } }
+{ $description "Returns the current floating-point rounding mode." } ;
+
+HELP: with-rounding-mode
+{ $values { "mode" fp-rounding-mode } { "quot" quotation } }
+{ $description "Sets the floating-point rounding mode to " { $snippet "mode" } " for the dynamic extent of " { $snippet "quot" } ", restoring the rounding mode to its original value on " { $snippet "quot" } "'s completion." } ;
+
+{ rounding-mode with-rounding-mode } related-words
+
+HELP: fp-traps
+{ $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "Returns the set of floating point exceptions with processor traps currently set." } ;
+
+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." } ;
+
+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
+
+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."
+$nl
+"Querying and setting exception flags:"
+{ $subsection fp-exception-flags }
+{ $subsection set-fp-exception-flags }
+{ $subsection clear-fp-exception-flags }
+{ $subsection collect-fp-exceptions }
+"Querying and controlling processor traps for floating-point exceptions:"
+{ $subsection fp-traps }
+{ $subsection with-fp-traps }
+{ $subsection without-fp-traps }
+"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." } ;
+
+ABOUT: "math.floats.env"
--- /dev/null
+USING: kernel math math.floats.env math.floats.env.private
+math.functions math.libm sets tools.test ;
+IN: math.floats.env.tests
+
+: set-default-fp-env ( -- )
+ { } { } +round-nearest+ +denormal-keep+ set-fp-env ;
+
+! 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+ } set=
+] unit-test
+
+[ t ] [
+ [ 1.0 3.0 / drop ] collect-fp-exceptions
+ { +fp-inexact+ } set=
+] unit-test
+
+[ t ] [
+ [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions
+ { +fp-inexact+ +fp-overflow+ } set=
+] unit-test
+
+[ t ] [
+ [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions
+ { +fp-inexact+ +fp-underflow+ } set=
+] unit-test
+
+[ t ] [
+ [ -1.0 fsqrt drop ] collect-fp-exceptions
+ { +fp-invalid-operation+ } set=
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-nearest+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,9999
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5556
+] [
+ +round-down+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5556
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,9999
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-up+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,9999
+ HEX: bfc9,9999,9999,9999
+ HEX: bfd5,5555,5555,5555
+] [
+ +round-zero+ [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+ ] with-rounding-mode
+] unit-test
+
+! ensure rounding mode is restored to +round-nearest+
+[
+ HEX: 3fd5,5555,5555,5555
+ HEX: 3fc9,9999,9999,999a
+ HEX: bfc9,9999,9999,999a
+ HEX: bfd5,5555,5555,5555
+] [
+ 1.0 3.0 /f double>bits
+ 1.0 5.0 /f double>bits
+ -1.0 5.0 /f double>bits
+ -1.0 3.0 /f double>bits
+] unit-test
+
+[
+ HEX: 0000,0000,0000,07e8
+] [
+ +denormal-keep+ [
+ 10.0 -320.0 ^ double>bits
+ ] with-denormal-mode
+] unit-test
+
+[
+ HEX: 0000,0000,0000,0000
+] [
+ +denormal-flush+ [
+ 10.0 -320.0 ^ double>bits
+ ] with-denormal-mode
+] unit-test
+
+! ensure denormal mode is restored to +denormal-keep+
+[
+ HEX: 0000,0000,0000,07e8
+] [
+ +denormal-keep+ [
+ 10.0 -320.0 ^ double>bits
+ ] with-denormal-mode
+] 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
+
+! Ensure traps get cleared
+[ 1/0. ] [ 1.0 0.0 /f ] unit-test
+
+! In case the tests screw up the FP env because of bugs in math.floats.env
+set-default-fp-env
+
--- /dev/null
+! (c)Joe Groff bsd license
+USING: alien.syntax assocs biassocs combinators continuations
+generalizations kernel literals locals math math.bitwise
+sequences system vocabs.loader ;
+IN: math.floats.env
+
+SINGLETONS:
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+ ;
+
+UNION: fp-exception
+ +fp-invalid-operation+
+ +fp-overflow+
+ +fp-underflow+
+ +fp-zero-divide+
+ +fp-inexact+ ;
+
+SINGLETONS:
+ +round-nearest+
+ +round-down+
+ +round-up+
+ +round-zero+ ;
+
+UNION: fp-rounding-mode
+ +round-nearest+
+ +round-down+
+ +round-up+
+ +round-zero+ ;
+
+SINGLETONS:
+ +denormal-keep+
+ +denormal-flush+ ;
+
+UNION: fp-denormal-mode
+ +denormal-keep+
+ +denormal-flush+ ;
+
+<PRIVATE
+
+HOOK: (fp-env-registers) cpu ( -- registers )
+
+: fp-env-register ( -- register ) (fp-env-registers) first ;
+
+:: mask> ( bits assoc -- symbols )
+ assoc [| k v | bits v mask zero? not ] assoc-filter keys ;
+: >mask ( symbols assoc -- bits )
+ over empty?
+ [ 2drop 0 ]
+ [ [ at ] curry [ bitor ] map-reduce ] if ;
+
+: remask ( x new-bits mask-bits -- x' )
+ [ unmask ] [ mask ] bi-curry bi* bitor ; inline
+
+GENERIC: (set-fp-env-register) ( fp-env -- )
+
+GENERIC: (get-exception-flags) ( fp-env -- exceptions )
+GENERIC# (set-exception-flags) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-fp-traps) ( fp-env -- exceptions )
+GENERIC# (set-fp-traps) 1 ( fp-env exceptions -- fp-env )
+
+GENERIC: (get-rounding-mode) ( fp-env -- mode )
+GENERIC# (set-rounding-mode) 1 ( fp-env mode -- fp-env )
+
+GENERIC: (get-denormal-mode) ( fp-env -- mode )
+GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
+
+: change-fp-env-registers ( quot -- )
+ (fp-env-registers) swap [ (set-fp-env-register) ] compose each ; inline
+
+: set-fp-traps ( exceptions -- ) [ (set-fp-traps) ] curry change-fp-env-registers ;
+: set-rounding-mode ( mode -- ) [ (set-rounding-mode) ] curry change-fp-env-registers ;
+: set-denormal-mode ( mode -- ) [ (set-denormal-mode) ] curry change-fp-env-registers ;
+
+: get-fp-env ( -- exception-flags fp-traps rounding-mode denormal-mode )
+ fp-env-register {
+ [ (get-exception-flags) ]
+ [ (get-fp-traps) ]
+ [ (get-rounding-mode) ]
+ [ (get-denormal-mode) ]
+ } cleave ;
+
+: set-fp-env ( exception-flags fp-traps rounding-mode denormal-mode -- )
+ [
+ {
+ [ [ (set-exception-flags) ] when* ]
+ [ [ (set-fp-traps) ] when* ]
+ [ [ (set-rounding-mode) ] when* ]
+ [ [ (set-denormal-mode) ] when* ]
+ } spread
+ ] 4 ncurry change-fp-env-registers ;
+
+PRIVATE>
+
+: fp-exception-flags ( -- exceptions ) fp-env-register (get-exception-flags) ;
+: set-fp-exception-flags ( exceptions -- ) [ (set-exception-flags) ] curry change-fp-env-registers ;
+: clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
+
+: collect-fp-exceptions ( quot -- exceptions )
+ clear-fp-exception-flags call fp-exception-flags ; inline
+
+: denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
+
+:: with-denormal-mode ( mode quot -- )
+ denormal-mode :> orig
+ mode set-denormal-mode
+ quot [ orig set-denormal-mode ] [ ] cleanup ; inline
+
+: rounding-mode ( -- mode ) fp-env-register (get-rounding-mode) ;
+
+:: with-rounding-mode ( mode quot -- )
+ rounding-mode :> orig
+ mode set-rounding-mode
+ quot [ orig set-rounding-mode ] [ ] cleanup ; inline
+
+: fp-traps ( -- exceptions ) fp-env-register (get-fp-traps) ;
+
+:: with-fp-traps ( exceptions quot -- )
+ fp-traps :> orig
+ exceptions set-fp-traps
+ quot [ orig set-fp-traps ] [ ] cleanup ; inline
+
+: without-fp-traps ( quot -- )
+ { } swap with-fp-traps ; inline
+
+<< {
+ { [ cpu x86? ] [ "math.floats.env.x86" require ] }
+ { [ cpu ppc? ] [ "math.floats.env.ppc" require ] }
+ [ "CPU architecture unsupported by math.floats.env" throw ]
+} cond >>
+
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators kernel literals math math.bitwise
+math.floats.env math.floats.env.private system ;
+IN: math.floats.env.ppc
+
+STRUCT: ppc-fpu-env
+ { padding uint }
+ { fpcsr 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 ) ;
+
+: <ppc-fpu-env> ( -- ppc-fpu-env )
+ ppc-fpu-env (struct)
+ [ get_ppc_fpu_env ] keep ;
+
+M: ppc-fpu-env (set-fp-env-register)
+ set_ppc_fpu_env ;
+
+M: ppc (fp-env-registers)
+ <ppc-fpu-env> 1array ;
+
+CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
+CONSTANT: ppc-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 2000,0000 }
+ { +fp-overflow+ HEX: 1000,0000 }
+ { +fp-underflow+ HEX: 0800,0000 }
+ { +fp-zero-divide+ HEX: 0400,0000 }
+ { +fp-inexact+ HEX: 0200,0000 }
+ }
+
+CONSTANT: ppc-fp-traps-bits HEX: f80
+CONSTANT: ppc-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 8000 }
+ { +fp-overflow+ HEX: 4000 }
+ { +fp-underflow+ HEX: 2000 }
+ { +fp-zero-divide+ HEX: 1000 }
+ { +fp-inexact+ HEX: 0800 }
+ }
+
+CONSTANT: ppc-rounding-mode-bits HEX: 3
+CONSTANT: ppc-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0 }
+ { +round-zero+ HEX: 1 }
+ { +round-up+ HEX: 2 }
+ { +round-down+ HEX: 3 }
+ } >biassoc ]
+
+CONSTANT: ppc-denormal-mode-bits HEX: 4
+
+M: ppc-fpu-env (get-exception-flags) ( register -- exceptions )
+ fpcsr>> ppc-exception-flag>bit mask> ; inline
+M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
+ [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
+ fpcsr>> not ppc-fp-traps>bit mask> ; inline
+M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
+ [ ppc-fp-traps>bit >mask not ppc-fp-traps-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
+ fpcsr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline
+M: ppc-fpu-env (set-rounding-mode) ( register mode -- register' )
+ [ ppc-rounding-mode>bit at ppc-rounding-mode-bits remask ] curry change-fpcsr ; inline
+
+M: ppc-fpu-env (get-denormal-mode) ( register -- mode )
+ fpcsr>> ppc-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ ppc-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ ppc-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-fpcsr ; inline
+
--- /dev/null
+IEEE 754 floating-point environment querying and control (exceptions, rounding mode, and denormals)
--- /dev/null
+USING: accessors alien.syntax arrays assocs biassocs
+classes.struct combinators cpu.x86.features kernel literals
+math math.bitwise math.floats.env math.floats.env.private
+system ;
+IN: math.floats.env.x86
+
+STRUCT: sse-env
+ { mxcsr uint } ;
+
+STRUCT: x87-env
+ { status ushort }
+ { control ushort } ;
+
+! defined in the vm, cpu-x86*.S
+FUNCTION: void get_sse_env ( sse-env* env ) ;
+FUNCTION: void set_sse_env ( sse-env* env ) ;
+
+FUNCTION: void get_x87_env ( x87-env* env ) ;
+FUNCTION: void set_x87_env ( x87-env* env ) ;
+
+: <sse-env> ( -- sse-env )
+ sse-env (struct) [ get_sse_env ] keep ;
+
+M: sse-env (set-fp-env-register)
+ set_sse_env ;
+
+: <x87-env> ( -- x87-env )
+ x87-env (struct) [ get_x87_env ] keep ;
+
+M: x87-env (set-fp-env-register)
+ set_x87_env ;
+
+M: x86 (fp-env-registers)
+ sse2?
+ [ <sse-env> <x87-env> 2array ]
+ [ <x87-env> 1array ] if ;
+
+CONSTANT: sse-exception-flag-bits HEX: 3f
+CONSTANT: sse-exception-flag>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: sse-fp-traps-bits HEX: 1f80
+CONSTANT: sse-fp-traps>bit
+ H{
+ { +fp-invalid-operation+ HEX: 0080 }
+ { +fp-overflow+ HEX: 0400 }
+ { +fp-underflow+ HEX: 0800 }
+ { +fp-zero-divide+ HEX: 0200 }
+ { +fp-inexact+ HEX: 1000 }
+ }
+
+CONSTANT: sse-rounding-mode-bits HEX: 6000
+CONSTANT: sse-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 2000 }
+ { +round-up+ HEX: 4000 }
+ { +round-zero+ HEX: 6000 }
+ } >biassoc ]
+
+CONSTANT: sse-denormal-mode-bits HEX: 8040
+
+M: sse-env (get-exception-flags) ( register -- exceptions )
+ mxcsr>> sse-exception-flag>bit mask> ; inline
+M: sse-env (set-exception-flags) ( register exceptions -- register' )
+ [ sse-exception-flag>bit >mask sse-exception-flag-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-fp-traps) ( register -- exceptions )
+ mxcsr>> bitnot sse-fp-traps>bit mask> ; inline
+M: sse-env (set-fp-traps) ( register exceptions -- register' )
+ [ sse-fp-traps>bit >mask bitnot sse-fp-traps-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-rounding-mode) ( register -- mode )
+ mxcsr>> sse-rounding-mode-bits mask sse-rounding-mode>bit value-at ; inline
+M: sse-env (set-rounding-mode) ( register mode -- register' )
+ [ sse-rounding-mode>bit at sse-rounding-mode-bits remask ] curry change-mxcsr ; inline
+
+M: sse-env (get-denormal-mode) ( register -- mode )
+ mxcsr>> sse-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: sse-env (set-denormal-mode) ( register mode -- register' )
+ [
+ {
+ { +denormal-keep+ [ sse-denormal-mode-bits unmask ] }
+ { +denormal-flush+ [ sse-denormal-mode-bits bitor ] }
+ } case
+ ] curry change-mxcsr ; inline
+
+CONSTANT: x87-exception-bits HEX: 3f
+CONSTANT: x87-exception>bit
+ H{
+ { +fp-invalid-operation+ HEX: 01 }
+ { +fp-overflow+ HEX: 08 }
+ { +fp-underflow+ HEX: 10 }
+ { +fp-zero-divide+ HEX: 04 }
+ { +fp-inexact+ HEX: 20 }
+ }
+
+CONSTANT: x87-rounding-mode-bits HEX: 0c00
+CONSTANT: x87-rounding-mode>bit
+ $[ H{
+ { +round-nearest+ HEX: 0000 }
+ { +round-down+ HEX: 0400 }
+ { +round-up+ HEX: 0800 }
+ { +round-zero+ HEX: 0c00 }
+ } >biassoc ]
+
+M: x87-env (get-exception-flags) ( register -- exceptions )
+ status>> x87-exception>bit mask> ; inline
+M: x87-env (set-exception-flags) ( register exceptions -- register' )
+ drop ;
+
+M: x87-env (get-fp-traps) ( register -- exceptions )
+ control>> bitnot x87-exception>bit mask> ; inline
+M: x87-env (set-fp-traps) ( register exceptions -- register' )
+ [ x87-exception>bit >mask bitnot x87-exception-bits remask ] curry change-control ; inline
+
+M: x87-env (get-rounding-mode) ( register -- mode )
+ control>> x87-rounding-mode-bits mask x87-rounding-mode>bit value-at ; inline
+M: x87-env (set-rounding-mode) ( register mode -- register' )
+ [ x87-rounding-mode>bit at x87-rounding-mode-bits remask ] curry change-control ; inline
+
+M: x87-env (get-denormal-mode) ( register -- mode )
+ drop +denormal-keep+ ; inline
+M: x87-env (set-denormal-mode) ( register mode -- register' )
+ drop ;
+
EPILOGUE
mtctr r3
bctr
+
+DEF(void,get_ppc_fpu_env,(void*)):
+ mffs fr0
+ stfd fr0,0(r3)
+ blr
+
+DEF(void,set_ppc_fpu_env,(const void*)):
+ lfd fr0,0(r3)
+ mtfsf 0xff,fr0
+ blr
add $12,%esp
jmp *%eax
+DEF(void,get_sse_env,(void*)):
+ movl 4(%esp), %eax
+ stmxcsr (%eax)
+ ret
+
+DEF(void,set_sse_env,(const void*)):
+ movl 4(%esp), %eax
+ ldmxcsr (%eax)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ movl 4(%esp), %eax
+ fnstsw (%eax)
+ fnstcw 2(%eax)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ movl 4(%esp), %eax
+ fldcw 2(%eax)
+ movb 4(%eax), %dl
+ test %dl, %dl
+ jz 1f
+ fnclex
+1:
+ ret
+
#include "cpu-x86.S"
#ifdef WINDOWS
.section .drectve
.ascii " -export:read_timestamp_counter"
+ .ascii " -export:get_sse_env"
+ .ascii " -export:set_sse_env"
+ .ascii " -export:get_x87_env"
+ .ascii " -export:set_x87_env"
#endif
add $STACK_PADDING,%rsp
jmp *%rax
+DEF(void,get_sse_env,(void*)):
+ stmxcsr (%rdi)
+ ret
+
+DEF(void,set_sse_env,(const void*)):
+ ldmxcsr (%rdi)
+ ret
+
+DEF(void,get_x87_env,(void*)):
+ fnstsw (%rdi)
+ fnstcw 2(%rdi)
+ ret
+
+DEF(void,set_x87_env,(const void*)):
+ fnclex
+ fldcw 2(%rdi)
+ ret
+
#include "cpu-x86.S"
general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
}
+void fp_trap_error()
+{
+ general_error(ERROR_FP_TRAP,F,F,NULL);
+}
+
PRIMITIVE(call_clear)
{
throw_impl(dpop(),stack_chain->callstack_bottom);
signal_error(signal_number,signal_callstack_top);
}
+void fp_signal_handler_impl()
+{
+ fp_trap_error();
+}
+
}
ERROR_RS_UNDERFLOW,
ERROR_RS_OVERFLOW,
ERROR_MEMORY,
+ ERROR_FP_TRAP,
};
void out_of_memory();
void signal_error(int signal, stack_frame *native_stack);
void type_error(cell type, cell tagged);
void not_implemented_error();
+void fp_trap_error();
PRIMITIVE(call_clear);
PRIMITIVE(unimplemented);
extern stack_frame *signal_callstack_top;
void memory_signal_handler_impl();
+void fp_signal_handler_impl();
void misc_signal_handler_impl();
}
/* Modify a suspended thread's thread_state so that when the thread resumes
executing, the call frame of the current C primitive (if any) is rewound, and
the appropriate Factor error is thrown from the top-most Factor frame. */
-static void call_fault_handler(exception_type_t exception,
+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)
{
signal_fault_addr = MACH_EXC_STATE_FAULT(exc_state);
MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
}
- else
- {
- if(exception == EXC_ARITHMETIC)
- signal_number = SIGFPE;
- else
- signal_number = SIGABRT;
+ else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
+ {
+ MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
+ }
+ else
+ {
+ signal_number = exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT;
MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
}
}
/* Modify registers so to have the thread resume executing the
fault handler */
- call_fault_handler(exception,&exc_state,&thread_state);
+ call_fault_handler(exception,code[0],&exc_state,&thread_state);
/* Set the faulting thread's register contents..
#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_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_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
UAP_PROGRAM_COUNTER(uap) = (cell)misc_signal_handler_impl;
}
+void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
+{
+ signal_number = signal;
+ signal_callstack_top = uap_stack_pointer(uap);
+ UAP_PROGRAM_COUNTER(uap) =
+ (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
+ ? (cell)misc_signal_handler_impl
+ : (cell)fp_signal_handler_impl;
+}
+
static void sigaction_safe(int signum, const struct sigaction *act, struct sigaction *oldact)
{
int ret;
{
struct sigaction memory_sigaction;
struct sigaction misc_sigaction;
+ struct sigaction fpe_sigaction;
struct sigaction ignore_sigaction;
memset(&memory_sigaction,0,sizeof(struct sigaction));
sigaction_safe(SIGBUS,&memory_sigaction,NULL);
sigaction_safe(SIGSEGV,&memory_sigaction,NULL);
+ memset(&fpe_sigaction,0,sizeof(struct sigaction));
+ sigemptyset(&fpe_sigaction.sa_mask);
+ fpe_sigaction.sa_sigaction = fpe_signal_handler;
+ fpe_sigaction.sa_flags = SA_SIGINFO;
+
+ sigaction_safe(SIGFPE,&fpe_sigaction,NULL);
+
memset(&misc_sigaction,0,sizeof(struct sigaction));
sigemptyset(&misc_sigaction.sa_mask);
misc_sigaction.sa_sigaction = misc_signal_handler;
misc_sigaction.sa_flags = SA_SIGINFO;
sigaction_safe(SIGABRT,&misc_sigaction,NULL);
- sigaction_safe(SIGFPE,&misc_sigaction,NULL);
sigaction_safe(SIGQUIT,&misc_sigaction,NULL);
sigaction_safe(SIGILL,&misc_sigaction,NULL);
projects / factor.git / commitdiff