steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge git://github.com/erikcharlebois/factor

release
Joe Groff 2010-04-14 13:21:03 -07:00
parent 1dadc4efed b4a0fd8b17
commit 1af11dbfb9
10 changed files with 447 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
extra/elf/a.elf Executable file
View File

Binary file not shown.

180
extra/elf/elf-tests.factor Normal file
View File

@ -0,0 +1,180 @@
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays elf kernel sequences tools.test ;
IN: elf.tests
{
{
""
".interp"
".note.ABI-tag"
".note.gnu.build-id"
".hash"
".gnu.hash"
".dynsym"
".dynstr"
".gnu.version"
".gnu.version_r"
".rela.dyn"
".rela.plt"
".init"
".plt"
".text"
".fini"
".rodata"
".eh_frame_hdr"
".eh_frame"
".ctors"
".dtors"
".jcr"
".dynamic"
".got"
".got.plt"
".data"
".bss"
".comment"
".debug_aranges"
".debug_pubnames"
".debug_info"
".debug_abbrev"
".debug_line"
".debug_str"
".shstrtab"
".symtab"
".strtab"
}
}
[
"resource:extra/elf/a.elf" [
sections [ name>> ] map
] with-mapped-elf
]
unit-test
{
{
".interp"
".note.ABI-tag"
".note.gnu.build-id"
".hash"
".gnu.hash"
".dynsym"
".dynstr"
".gnu.version"
".gnu.version_r"
".rela.dyn"
".rela.plt"
".init"
".plt"
".text"
".fini"
".rodata"
".eh_frame_hdr"
".eh_frame"
}
}
[
"resource:extra/elf/a.elf" [
segments [ program-header>> p_type>> PT_LOAD = ] find nip
sections [ name>> ] map
] with-mapped-elf
]
unit-test
{
{
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
""
"init.c"
"call_gmon_start"
"crtstuff.c"
"__CTOR_LIST__"
"__DTOR_LIST__"
"__JCR_LIST__"
"__do_global_dtors_aux"
"completed.7342"
"dtor_idx.7344"
"frame_dummy"
"crtstuff.c"
"__CTOR_END__"
"__FRAME_END__"
"__JCR_END__"
"__do_global_ctors_aux"
"test.c"
"_GLOBAL_OFFSET_TABLE_"
"__init_array_end"
"__init_array_start"
"_DYNAMIC"
"data_start"
"printf@@GLIBC_2.2.5"
"__libc_csu_fini"
"_start"
"__gmon_start__"
"_Jv_RegisterClasses"
"_fini"
"__libc_start_main@@GLIBC_2.2.5"
"_IO_stdin_used"
"__data_start"
"__dso_handle"
"__DTOR_END__"
"__libc_csu_init"
"__bss_start"
"_end"
"_edata"
"main"
"_init"
}
}
[
"resource:extra/elf/a.elf" [
sections ".symtab" find-section symbols
[ name>> ] map
] with-mapped-elf
]
unit-test
{
B{
85 72 137 229 184 44 6 64 0 72 137 199 184 0 0 0 0 232 222
254 255 255 201 195
}
}
[
"resource:extra/elf/a.elf" [
sections ".symtab" "main" find-section-symbol
symbol-data >byte-array
] with-mapped-elf
]
unit-test

16
extra/elf/elf.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.strings alien.syntax arrays
classes.struct fry io.encodings.ascii kernel locals math
classes.struct fry io.encodings.ascii io.mmap kernel locals math
math.intervals sequences specialized-arrays strings typed ;
IN: elf
@ -611,4 +611,16 @@ M:: segment sections ( segment -- sections )
symbol sym>> st_size>> <direct-uchar-array> ;
: find-section ( sections name -- section/f )
'[ name>> _ = ] find nip ;
'[ name>> _ = ] find nip ; inline
: find-symbol ( symbols name -- symbol/f )
'[ name>> _ = ] find nip ; inline
: find-section-symbol ( sections section symbol -- symbol/f )
[ find-section ] dip over [
[ symbols ] dip find-symbol ] [ 2drop f ] if ;
: with-mapped-elf ( path quot -- )
'[
address>> <elf> @
] with-mapped-file ; inline

2
extra/elf/nm/nm-docs.factor
View File

@ -16,7 +16,7 @@ HELP: print-symbol
{ $description "Prints the value, section and name of the given symbol." } ;
ARTICLE: "elf.nm" "ELF nm"
{ $description "Utility to print the values, sections and names of the symbols in a given ELF file. In an ELF executable or shared library, the symbol values are typically their virtual addresses. In a relocatable ELF object, they are section-relative offsets." }
"The " { $vocab-link "elf.nm" } " vocab prints the values, sections and names of the symbols in a given ELF file. In an ELF executable or shared library, the symbol values are typically their virtual addresses. In a relocatable ELF object, they are section-relative offsets."
;
ABOUT: "elf.nm"

51
extra/elf/nm/nm-tests.factor Normal file
View File

@ -0,0 +1,51 @@
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
USING: elf.nm io io.streams.string kernel multiline strings tools.test
literals ;
IN: elf.nm.tests
STRING: validation-output
0000000000000000 absolute init.c
000000000040046c .text call_gmon_start
0000000000000000 absolute crtstuff.c
0000000000600e18 .ctors __CTOR_LIST__
0000000000600e28 .dtors __DTOR_LIST__
0000000000600e38 .jcr __JCR_LIST__
0000000000400490 .text __do_global_dtors_aux
0000000000601020 .bss completed.7342
0000000000601028 .bss dtor_idx.7344
0000000000400500 .text frame_dummy
0000000000000000 absolute crtstuff.c
0000000000600e20 .ctors __CTOR_END__
00000000004006d8 .eh_frame __FRAME_END__
0000000000600e38 .jcr __JCR_END__
00000000004005e0 .text __do_global_ctors_aux
0000000000000000 absolute test.c
0000000000600fe8 .got.plt _GLOBAL_OFFSET_TABLE_
0000000000600e14 .ctors __init_array_end
0000000000600e14 .ctors __init_array_start
0000000000600e40 .dynamic _DYNAMIC
0000000000601010 .data data_start
0000000000000000 undefined printf@@GLIBC_2.2.5
0000000000400540 .text __libc_csu_fini
0000000000400440 .text _start
0000000000000000 undefined __gmon_start__
0000000000000000 undefined _Jv_RegisterClasses
0000000000400618 .fini _fini
0000000000000000 undefined __libc_start_main@@GLIBC_2.2.5
0000000000400628 .rodata _IO_stdin_used
0000000000601010 .data __data_start
0000000000601018 .data __dso_handle
0000000000600e30 .dtors __DTOR_END__
0000000000400550 .text __libc_csu_init
0000000000601020 absolute __bss_start
0000000000601030 absolute _end
0000000000601020 absolute _edata
0000000000400524 .text main
00000000004003f0 .init _init
;
{ $ validation-output }
[ <string-writer> dup [ "resource:extra/elf/a.elf" elf-nm ] with-output-stream >string ]
unit-test

9
extra/elf/nm/nm.factor
View File

@ -4,7 +4,7 @@ USING: accessors combinators elf formatting io.mmap kernel sequences ;
IN: elf.nm
: print-symbol ( sections symbol -- )
[ sym>> st_value>> "%016d " printf ]
[ sym>> st_value>> "%016x " printf ]
[
sym>> st_shndx>>
{
@ -16,10 +16,9 @@ IN: elf.nm
]
[ name>> "%s\n" printf ] tri ;
: nm ( path -- )
: elf-nm ( path -- )
[
address>> <elf> sections
dup ".symtab" find-section
sections dup ".symtab" find-section
symbols [ name>> empty? not ] filter
[ print-symbol ] with each
] with-mapped-file ;
] with-mapped-elf ;

BIN
extra/macho/a.macho Executable file
View File

Binary file not shown.

26
extra/macho/macho-tests.factor Normal file
View File

@ -0,0 +1,26 @@
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
USING: io io.streams.string kernel literals macho multiline strings
tools.test ;
IN: macho.tests
STRING: validation-output
0000000100000f1c __stub_helper stub helpers
0000000100001040 __program_vars _pvars
0000000100001068 __data _NXArgc
0000000100001070 __data _NXArgv
0000000100001080 __data ___progname
0000000100000000 __mh_execute_header
0000000100001078 __data _environ
0000000100000ef8 __text _main
0000000100000ebc __text start
0000000000000000 ___gxx_personality_v0
0000000000000000 _exit
0000000000000000 _printf
0000000000000000 dyld_stub_binder
;
{ $ validation-output }
[ <string-writer> dup [ "resource:extra/macho/a.macho" macho-nm ] with-output-stream >string ]
unit-test

128
extra/macho/macho.factor
View File

@ -1,8 +1,13 @@
! Copyright (C) 2010 Erik Charlebois.
! See http:// factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax classes.struct kernel literals math ;
USING: accessors alien alien.c-types alien.strings alien.syntax
classes classes.struct combinators io.encodings.ascii
io.encodings.string kernel literals make math sequences
specialized-arrays typed fry io.mmap formatting locals ;
FROM: alien.c-types => short ;
IN: macho
! FFI data
TYPEDEF: int integer_t
TYPEDEF: int vm_prot_t
TYPEDEF: integer_t cpu_type_t
@ -804,3 +809,124 @@ C-ENUM: reloc_type_ppc
PPC_RELOC_JBSR
PPC_RELOC_LO14_SECTDIFF
PPC_RELOC_LOCAL_SECTDIFF ;
! Low-level interface
SPECIALIZED-ARRAYS: section section_64 nlist nlist_64 ;
UNION: mach_header_32/64 mach_header mach_header_64 ;
UNION: segment_command_32/64 segment_command segment_command_64 ;
UNION: load-command segment_command segment_command_64
dylib_command sub_framework_command
sub_client_command sub_umbrella_command sub_library_command
prebound_dylib_command dylinker_command thread_command
routines_command routines_command_64 symtab_command
dysymtab_command twolevel_hints_command uuid_command ;
UNION: section_32/64 section section_64 ;
UNION: section_32/64-array section-array section_64-array ;
UNION: nlist_32/64 nlist nlist_64 ;
UNION: nlist_32/64-array nlist-array nlist_64-array ;
TYPED: 64-bit? ( macho: mach_header_32/64 -- ? )
magic>> {
{ MH_MAGIC_64 [ t ] }
{ MH_CIGAM_64 [ t ] }
[ drop f ]
} case ;
TYPED: macho-header ( c-ptr -- macho: mach_header_32/64 )
dup mach_header_64 memory>struct 64-bit?
[ mach_header_64 memory>struct ]
[ mach_header memory>struct ] if ;
: cmd>load-command ( cmd -- load-command )
{
{ LC_UUID [ uuid_command ] }
{ LC_SEGMENT [ segment_command ] }
{ LC_SEGMENT_64 [ segment_command_64 ] }
{ LC_SYMTAB [ symtab_command ] }
{ LC_DYSYMTAB [ dysymtab_command ] }
{ LC_THREAD [ thread_command ] }
{ LC_UNIXTHREAD [ thread_command ] }
{ LC_LOAD_DYLIB [ dylib_command ] }
{ LC_ID_DYLIB [ dylib_command ] }
{ LC_PREBOUND_DYLIB [ prebound_dylib_command ] }
{ LC_LOAD_DYLINKER [ dylinker_command ] }
{ LC_ID_DYLINKER [ dylinker_command ] }
{ LC_ROUTINES [ routines_command ] }
{ LC_ROUTINES_64 [ routines_command_64 ] }
{ LC_TWOLEVEL_HINTS [ twolevel_hints_command ] }
{ LC_SUB_FRAMEWORK [ sub_framework_command ] }
{ LC_SUB_UMBRELLA [ sub_umbrella_command ] }
{ LC_SUB_LIBRARY [ sub_library_command ] }
{ LC_SUB_CLIENT [ sub_client_command ] }
{ LC_DYLD_INFO [ dyld_info_command ] }
{ LC_DYLD_INFO_ONLY [ dyld_info_command ] }
} case ;
: read-command ( cmd -- next-cmd )
dup load_command memory>struct
[ cmd>> cmd>load-command memory>struct , ]
[ cmdsize>> swap <displaced-alien> ] 2bi ;
TYPED: load-commands ( macho: mach_header_32/64 -- load-commands )
[
[ class heap-size ]
[ >c-ptr <displaced-alien> ]
[ ncmds>> ] tri iota [
drop read-command
] each drop
] { } make ;
: segment-commands ( load-commands -- segment-commands )
[ segment_command_32/64? ] filter ; inline
: symtab-commands ( load-commands -- segment-commands )
[ symtab_command? ] filter ; inline
: read-array-string ( uchar-array -- string )
ascii decode [ 0 = not ] filter ;
: segment-sections ( segment-command -- sections )
{
[ class heap-size ]
[ >c-ptr <displaced-alien> ]
[ nsects>> ]
[ segment_command_64? ]
} cleave
[ <direct-section_64-array> ]
[ <direct-section-array> ] if ;
: sections-array ( segment-commands -- sections-array )
[
dup first segment_command_64?
[ section_64 ] [ section ] if <struct> ,
segment-commands [ segment-sections [ , ] each ] each
] { } make ;
: symbols ( mach-header symtab-command -- symbols string-table )
[ symoff>> swap >c-ptr <displaced-alien> ]
[ nsyms>> swap 64-bit?
[ <direct-nlist_64-array> ]
[ <direct-nlist-array> ] if ]
[ stroff>> swap >c-ptr <displaced-alien> ] 2tri ;
: symbol-name ( symbol string-table -- name )
[ n_strx>> ] dip <displaced-alien> ascii alien>string ;
: with-mapped-macho ( path quot -- )
'[
address>> macho-header @
] with-mapped-file ; inline
: macho-nm ( path -- )
[| macho |
macho load-commands segment-commands sections-array :> sections
macho load-commands symtab-commands [| symtab |
macho symtab symbols [
[ drop n_value>> "%016x " printf ]
[ drop n_sect>> sections nth sectname>>
read-array-string "%-16s" printf ]
[ symbol-name "%s\n" printf ] 2tri
] curry each
] each
] with-mapped-macho ;

81
extra/opencl/opencl.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2010 Erik Charlebois.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.accessors alien.c-types arrays
byte-arrays combinators combinators.smart continuations destructors
fry io.encodings.ascii io.encodings.string kernel libc locals macros
math math.order multiline opencl.ffi prettyprint sequences
specialized-arrays typed variants namespaces ;
USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.smart destructors io.encodings.ascii io.encodings.string
kernel libc locals math namespaces opencl.ffi sequences shuffle
specialized-arrays variants ;
IN: opencl
SPECIALIZED-ARRAYS: void* char size_t ;
@ -16,17 +15,25 @@ ERROR: cl-error err ;
: cl-not-null ( err -- )
dup f = [ cl-error ] [ drop ] if ; inline
: info-data-size ( handle name info-quot -- size_t )
[ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
MACRO: info ( info-quot lift-quot -- quot )
[ dup ] dip '[ 2dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
*size_t dup <byte-array> _ '[ f _ call cl-success ] keep
_ call ] ;
MACRO: 2info ( info-quot lift-quot -- quot )
[ dup ] dip '[ 3dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
*size_t dup <byte-array> _ '[ f _ call cl-success ] keep
_ call ] ;
: info-data-bytes ( handle name info-quot size -- bytes )
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
: info ( handle name info-quot lift-quot -- value )
[ 3dup info-data-size info-data-bytes ] dip call ; inline
: 2info-data-size ( handle1 handle2 name info-quot -- size_t )
[ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
: 2info-data-bytes ( handle1 handle2 name info-quot size -- bytes )
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
: 2info ( handle1 handle2 name info_quot lift_quot -- value )
[ 4dup 2info-data-size 2info-data-bytes ] dip call ; inline
: info-bool ( handle name quot -- ? )
[ *uint CL_TRUE = ] info ; inline
@ -156,6 +163,7 @@ C: <cl-buffer-range> cl-buffer-range
SYMBOLS: cl-current-context cl-current-queue cl-current-device ;
<PRIVATE
: (current-cl-context) ( -- cl-context )
cl-current-context get ; inline
@ -200,7 +208,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
} case ; inline
: platform-info-string ( handle name -- string )
[ clGetPlatformInfo ] info-string ; inline
[ clGetPlatformInfo ] info-string ;
: platform-info ( id -- profile version name vendor extensions )
{
@ -229,22 +237,22 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
} case ; inline
: device-info-bool ( handle name -- ? )
[ clGetDeviceInfo ] info-bool ; inline
[ clGetDeviceInfo ] info-bool ;
: device-info-ulong ( handle name -- ulong )
[ clGetDeviceInfo ] info-ulong ; inline
[ clGetDeviceInfo ] info-ulong ;
: device-info-uint ( handle name -- uint )
[ clGetDeviceInfo ] info-uint ; inline
[ clGetDeviceInfo ] info-uint ;
: device-info-string ( handle name -- string )
[ clGetDeviceInfo ] info-string ; inline
[ clGetDeviceInfo ] info-string ;
: device-info-size_t ( handle name -- size_t )
[ clGetDeviceInfo ] info-size_t ; inline
[ clGetDeviceInfo ] info-size_t ;
: device-info-size_t-array ( handle name -- size_t-array )
[ clGetDeviceInfo ] info-size_t-array ; inline
[ clGetDeviceInfo ] info-size_t-array ;
: device-info ( device-id -- device )
dup {
@ -309,23 +317,23 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
] 2bi ; inline
: command-queue-info-ulong ( handle name -- ulong )
[ clGetCommandQueueInfo ] info-ulong ; inline
[ clGetCommandQueueInfo ] info-ulong ;
: sampler-info-bool ( handle name -- ? )
[ clGetSamplerInfo ] info-bool ; inline
[ clGetSamplerInfo ] info-bool ;
: sampler-info-uint ( handle name -- uint )
[ clGetSamplerInfo ] info-uint ; inline
[ clGetSamplerInfo ] info-uint ;
: program-build-info-string ( program-handle device-handle name -- string )
[ clGetProgramBuildInfo ] 2info-string ; inline
[ clGetProgramBuildInfo ] 2info-string ;
: program-build-log ( program-handle device-handle -- string )
CL_PROGRAM_BUILD_LOG program-build-info-string ; inline
CL_PROGRAM_BUILD_LOG program-build-info-string ;
: strings>char*-array ( strings -- char*-array )
[ ascii encode dup length dup malloc [ cl-not-null ]
keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ; inline
keep &free [ -rot memcpy ] keep ] void*-array{ } map-as ;
: (program) ( cl-context sources -- program-handle )
[ handle>> ] dip [
@ -347,19 +355,19 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
} case ;
: kernel-info-string ( handle name -- string )
[ clGetKernelInfo ] info-string ; inline
[ clGetKernelInfo ] info-string ;
: kernel-info-uint ( handle name -- uint )
[ clGetKernelInfo ] info-uint ; inline
[ clGetKernelInfo ] info-uint ;
: kernel-work-group-info-size_t ( handle1 handle2 name -- size_t )
[ clGetKernelWorkGroupInfo ] 2info-size_t ; inline
[ clGetKernelWorkGroupInfo ] 2info-size_t ;
: event-info-uint ( handle name -- uint )
[ clGetEventInfo ] info-uint ; inline
[ clGetEventInfo ] info-uint ;
: event-info-int ( handle name -- int )
[ clGetEventInfo ] info-int ; inline
[ clGetEventInfo ] info-int ;
: cl_command_type>command-type ( cl_command-type -- command-type )
{
@ -392,8 +400,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
} case ; inline
: profiling-info-ulong ( handle name -- ulong )
[ clGetEventProfilingInfo ] info-ulong ; inline
[ clGetEventProfilingInfo ] info-ulong ;
: bind-kernel-arg-buffer ( kernel index buffer -- )
[ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
@ -528,10 +535,10 @@ PRIVATE>
cl-kernel new-disposable swap >>handle ; inline
: cl-kernel-name ( kernel -- string )
handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ; inline
handle>> CL_KERNEL_FUNCTION_NAME kernel-info-string ;
: cl-kernel-arity ( kernel -- arity )
handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ; inline
handle>> CL_KERNEL_NUM_ARGS kernel-info-uint ;
: cl-kernel-local-size ( kernel -- size )
(current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline