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/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 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..800b343dfd 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 (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; + } +} + #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..b2dd096137 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 (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; + } +} + #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;