USING: accessors alien alien.c-types alien.data alien.syntax arrays assocs classes.struct combinators compiler.codegen.fixup compiler.constants cpu.x86 cpu.x86.assembler cpu.x86.assembler.operands destructors generalizations grouping hashtables io.binary kernel libc literals locals math.vectors.simd multiline namespaces prettyprint sequences specialized-arrays tools.time windows.kernel32 windows.errors alien.accessors utils cpu.architecture ; EXCLUDE: math => float ; SPECIALIZED-ARRAYS: float double void* uint ; IN: mt c-bool INFINITE WaitForMultipleObjects WAIT_FAILED = [ win32-error ] when ; : virtual-alloc ( size -- alien ) [ GetCurrentProcess f ] dip flags{ MEM_COMMIT MEM_RESERVE } PAGE_EXECUTE_READWRITE VirtualAllocEx ; : virtual-free ( alien -- ) [ GetCurrentProcess ] dip 0 MEM_RELEASE VirtualFreeEx win32-error=0/f ; PRIVATE> ! %bug?: doesn't seem to work if you yield around ! : par-exec ( data/fptr -- ) ! [ first2 create-thread dup &dispose ] map [ first2 swap create-thread ] map [ length ] [ >void*-array wait-threads ] [ [ CloseHandle win32-error=0/f ] each ] tri ; : par-each ( data fptr -- ) [ 2array ] curry map par-exec ; ( -- cr ) f 0 0 H{ } clone code-repository boa ; : alloc-block ( size -- alien ) virtual-alloc ; : free-block ( alien -- ) virtual-free ; :: increase-capacity ( cr -- ) cr size>> 0 = [ 1024 alloc-block cr memory-block<< 1024 cr size<< ] [ cr size>> 2 * cr size<< cr memory-block>> free-block cr size>> alloc-block cr memory-block<< ] if ; :: allocate ( code cr -- alien ) [ cr ptr>> code length + cr size>> > ] [ cr increase-capacity ] while cr ptr>> cr memory-block>> [ code code length memcpy ] keep cr ptr>> code length + cr ptr<< ; : flush-code-repository ( -- ) code-repository get-global { [ memory-block>> dup dup expired? not and [ free-block ] [ drop ] if ] [ f swap memory-block<< ] [ 0 swap ptr<< ] [ 0 swap size<< ] [ table>> values [ f swap set-second ] each ] } cleave ; : revive ( cr -- cr ) dup memory-block>> expired? [ flush-code-repository ] when ; PRIVATE> : get-func ( name -- fptr ) code-repository get-global revive table>> at dup second [ second ] [ [ first call( -- fptr ) code-repository get-global allocate dup ] keep set-second ] if ; code-repository set-global : register ( quot name -- ) [ f 2array ] dip code-repository get-global table>> set-at ; :: link-jumps ( code -- binary ) 3 code nth 3 group :> labels code last :> binary labels [| l | l first rc-relative assert= ! rc-relative l third l second - l second 4 - binary copy ] each binary ; PRIVATE> : gen-foo ( -- fptr ) [ EAX 666 MOV 0 RET ] with-fixup link-jumps ; [ gen-foo ] "foo" register :: gen-rmw ( -- fptr ) { "ptr" } [ 4 * 4 + 2array ] map-index >hashtable :> args [ EDX "ptr" args at stack@ MOV EAX EDX [] MOV EAX 1 ADD EDX [] EAX MOV ! EAX EDX MOV 0 RET ] with-fixup link-jumps ; [ gen-rmw ] "rmw" register :: gen-barrier ( -- fptr ) { "ptr" } [ 4 * 4 + 2array ] map-index >hashtable :> args [ EDX "ptr" args at stack@ MOV MFENCE LOCK EDX [] DEC