Merge git://github.com/erikcharlebois/factor
Joe Groff
commit
1af11dbfb9
Binary file not shown.
|
|
@ -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
|
||||||
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2010 Erik Charlebois.
|
! Copyright (C) 2010 Erik Charlebois.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.c-types alien.strings alien.syntax arrays
|
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 ;
|
math.intervals sequences specialized-arrays strings typed ;
|
||||||
IN: elf
|
IN: elf
|
||||||
|
|
||||||
|
|
@ -611,4 +611,16 @@ M:: segment sections ( segment -- sections )
|
||||||
symbol sym>> st_size>> <direct-uchar-array> ;
|
symbol sym>> st_size>> <direct-uchar-array> ;
|
||||||
|
|
||||||
: find-section ( sections name -- section/f )
|
: 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
|
||||||
|
|
|
||||||
|
|
@ -16,7 +16,7 @@ HELP: print-symbol
|
||||||
{ $description "Prints the value, section and name of the given symbol." } ;
|
{ $description "Prints the value, section and name of the given symbol." } ;
|
||||||
|
|
||||||
ARTICLE: "elf.nm" "ELF nm"
|
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"
|
ABOUT: "elf.nm"
|
||||||
|
|
|
||||||
|
|
@ -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
|
||||||
|
|
@ -4,7 +4,7 @@ USING: accessors combinators elf formatting io.mmap kernel sequences ;
|
||||||
IN: elf.nm
|
IN: elf.nm
|
||||||
|
|
||||||
: print-symbol ( sections symbol -- )
|
: print-symbol ( sections symbol -- )
|
||||||
[ sym>> st_value>> "%016d " printf ]
|
[ sym>> st_value>> "%016x " printf ]
|
||||||
[
|
[
|
||||||
sym>> st_shndx>>
|
sym>> st_shndx>>
|
||||||
{
|
{
|
||||||
|
|
@ -16,10 +16,9 @@ IN: elf.nm
|
||||||
]
|
]
|
||||||
[ name>> "%s\n" printf ] tri ;
|
[ name>> "%s\n" printf ] tri ;
|
||||||
|
|
||||||
: nm ( path -- )
|
: elf-nm ( path -- )
|
||||||
[
|
[
|
||||||
address>> <elf> sections
|
sections dup ".symtab" find-section
|
||||||
dup ".symtab" find-section
|
|
||||||
symbols [ name>> empty? not ] filter
|
symbols [ name>> empty? not ] filter
|
||||||
[ print-symbol ] with each
|
[ print-symbol ] with each
|
||||||
] with-mapped-file ;
|
] with-mapped-elf ;
|
||||||
|
|
|
||||||
Binary file not shown.
|
|
@ -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
|
||||||
|
|
@ -1,8 +1,13 @@
|
||||||
! Copyright (C) 2010 Erik Charlebois.
|
! Copyright (C) 2010 Erik Charlebois.
|
||||||
! See http:// factorcode.org/license.txt for BSD license.
|
! 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
|
IN: macho
|
||||||
|
|
||||||
|
! FFI data
|
||||||
TYPEDEF: int integer_t
|
TYPEDEF: int integer_t
|
||||||
TYPEDEF: int vm_prot_t
|
TYPEDEF: int vm_prot_t
|
||||||
TYPEDEF: integer_t cpu_type_t
|
TYPEDEF: integer_t cpu_type_t
|
||||||
|
|
@ -804,3 +809,124 @@ C-ENUM: reloc_type_ppc
|
||||||
PPC_RELOC_JBSR
|
PPC_RELOC_JBSR
|
||||||
PPC_RELOC_LO14_SECTDIFF
|
PPC_RELOC_LO14_SECTDIFF
|
||||||
PPC_RELOC_LOCAL_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 ;
|
||||||
|
|
|
||||||
|
|
@ -1,10 +1,9 @@
|
||||||
! Copyright (C) 2010 Erik Charlebois.
|
! Copyright (C) 2010 Erik Charlebois.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors alien alien.accessors alien.c-types arrays
|
USING: accessors alien alien.c-types arrays byte-arrays combinators
|
||||||
byte-arrays combinators combinators.smart continuations destructors
|
combinators.smart destructors io.encodings.ascii io.encodings.string
|
||||||
fry io.encodings.ascii io.encodings.string kernel libc locals macros
|
kernel libc locals math namespaces opencl.ffi sequences shuffle
|
||||||
math math.order multiline opencl.ffi prettyprint sequences
|
specialized-arrays variants ;
|
||||||
specialized-arrays typed variants namespaces ;
|
|
||||||
IN: opencl
|
IN: opencl
|
||||||
SPECIALIZED-ARRAYS: void* char size_t ;
|
SPECIALIZED-ARRAYS: void* char size_t ;
|
||||||
|
|
||||||
|
|
@ -16,17 +15,25 @@ ERROR: cl-error err ;
|
||||||
|
|
||||||
: cl-not-null ( err -- )
|
: cl-not-null ( err -- )
|
||||||
dup f = [ cl-error ] [ drop ] if ; inline
|
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 )
|
: info-data-bytes ( handle name info-quot size -- bytes )
|
||||||
[ dup ] dip '[ 2dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
|
swap [ dup <byte-array> f ] dip [ call cl-success ] 3keep 2drop ; inline
|
||||||
*size_t dup <byte-array> _ '[ f _ call cl-success ] keep
|
|
||||||
_ call ] ;
|
: info ( handle name info-quot lift-quot -- value )
|
||||||
|
[ 3dup info-data-size info-data-bytes ] dip call ; inline
|
||||||
MACRO: 2info ( info-quot lift-quot -- quot )
|
|
||||||
[ dup ] dip '[ 3dup 0 f 0 <size_t> _ '[ _ call cl-success ] keep
|
: 2info-data-size ( handle1 handle2 name info-quot -- size_t )
|
||||||
*size_t dup <byte-array> _ '[ f _ call cl-success ] keep
|
[ 0 f 0 <size_t> ] dip [ call cl-success ] 2keep drop *size_t ; inline
|
||||||
_ call ] ;
|
|
||||||
|
: 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 -- ? )
|
: info-bool ( handle name quot -- ? )
|
||||||
[ *uint CL_TRUE = ] info ; inline
|
[ *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 ;
|
SYMBOLS: cl-current-context cl-current-queue cl-current-device ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: (current-cl-context) ( -- cl-context )
|
: (current-cl-context) ( -- cl-context )
|
||||||
cl-current-context get ; inline
|
cl-current-context get ; inline
|
||||||
|
|
||||||
|
|
@ -200,7 +208,7 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
|
||||||
} case ; inline
|
} case ; inline
|
||||||
|
|
||||||
: platform-info-string ( handle name -- string )
|
: platform-info-string ( handle name -- string )
|
||||||
[ clGetPlatformInfo ] info-string ; inline
|
[ clGetPlatformInfo ] info-string ;
|
||||||
|
|
||||||
: platform-info ( id -- profile version name vendor extensions )
|
: 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
|
} case ; inline
|
||||||
|
|
||||||
: device-info-bool ( handle name -- ? )
|
: device-info-bool ( handle name -- ? )
|
||||||
[ clGetDeviceInfo ] info-bool ; inline
|
[ clGetDeviceInfo ] info-bool ;
|
||||||
|
|
||||||
: device-info-ulong ( handle name -- ulong )
|
: device-info-ulong ( handle name -- ulong )
|
||||||
[ clGetDeviceInfo ] info-ulong ; inline
|
[ clGetDeviceInfo ] info-ulong ;
|
||||||
|
|
||||||
: device-info-uint ( handle name -- uint )
|
: device-info-uint ( handle name -- uint )
|
||||||
[ clGetDeviceInfo ] info-uint ; inline
|
[ clGetDeviceInfo ] info-uint ;
|
||||||
|
|
||||||
: device-info-string ( handle name -- string )
|
: device-info-string ( handle name -- string )
|
||||||
[ clGetDeviceInfo ] info-string ; inline
|
[ clGetDeviceInfo ] info-string ;
|
||||||
|
|
||||||
: device-info-size_t ( handle name -- size_t )
|
: 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 )
|
: 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 )
|
: device-info ( device-id -- device )
|
||||||
dup {
|
dup {
|
||||||
|
|
@ -309,23 +317,23 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
|
||||||
] 2bi ; inline
|
] 2bi ; inline
|
||||||
|
|
||||||
: command-queue-info-ulong ( handle name -- ulong )
|
: command-queue-info-ulong ( handle name -- ulong )
|
||||||
[ clGetCommandQueueInfo ] info-ulong ; inline
|
[ clGetCommandQueueInfo ] info-ulong ;
|
||||||
|
|
||||||
: sampler-info-bool ( handle name -- ? )
|
: sampler-info-bool ( handle name -- ? )
|
||||||
[ clGetSamplerInfo ] info-bool ; inline
|
[ clGetSamplerInfo ] info-bool ;
|
||||||
|
|
||||||
: sampler-info-uint ( handle name -- uint )
|
: sampler-info-uint ( handle name -- uint )
|
||||||
[ clGetSamplerInfo ] info-uint ; inline
|
[ clGetSamplerInfo ] info-uint ;
|
||||||
|
|
||||||
: program-build-info-string ( program-handle device-handle name -- string )
|
: 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 )
|
: 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 )
|
: strings>char*-array ( strings -- char*-array )
|
||||||
[ ascii encode dup length dup malloc [ cl-not-null ]
|
[ 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 )
|
: (program) ( cl-context sources -- program-handle )
|
||||||
[ handle>> ] dip [
|
[ handle>> ] dip [
|
||||||
|
|
@ -347,19 +355,19 @@ M: cl-filter-linear filter-mode-constant drop CL_FILTER_LINEAR ;
|
||||||
} case ;
|
} case ;
|
||||||
|
|
||||||
: kernel-info-string ( handle name -- string )
|
: kernel-info-string ( handle name -- string )
|
||||||
[ clGetKernelInfo ] info-string ; inline
|
[ clGetKernelInfo ] info-string ;
|
||||||
|
|
||||||
: kernel-info-uint ( handle name -- uint )
|
: kernel-info-uint ( handle name -- uint )
|
||||||
[ clGetKernelInfo ] info-uint ; inline
|
[ clGetKernelInfo ] info-uint ;
|
||||||
|
|
||||||
: kernel-work-group-info-size_t ( handle1 handle2 name -- size_t )
|
: 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 )
|
: event-info-uint ( handle name -- uint )
|
||||||
[ clGetEventInfo ] info-uint ; inline
|
[ clGetEventInfo ] info-uint ;
|
||||||
|
|
||||||
: event-info-int ( handle name -- int )
|
: event-info-int ( handle name -- int )
|
||||||
[ clGetEventInfo ] info-int ; inline
|
[ clGetEventInfo ] info-int ;
|
||||||
|
|
||||||
: cl_command_type>command-type ( cl_command-type -- command-type )
|
: 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
|
} case ; inline
|
||||||
|
|
||||||
: profiling-info-ulong ( handle name -- ulong )
|
: profiling-info-ulong ( handle name -- ulong )
|
||||||
[ clGetEventProfilingInfo ] info-ulong ; inline
|
[ clGetEventProfilingInfo ] info-ulong ;
|
||||||
|
|
||||||
|
|
||||||
: bind-kernel-arg-buffer ( kernel index buffer -- )
|
: bind-kernel-arg-buffer ( kernel index buffer -- )
|
||||||
[ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
|
[ handle>> ] [ cl_mem heap-size ] [ handle>> <void*> ] tri*
|
||||||
|
|
@ -528,10 +535,10 @@ PRIVATE>
|
||||||
cl-kernel new-disposable swap >>handle ; inline
|
cl-kernel new-disposable swap >>handle ; inline
|
||||||
|
|
||||||
: cl-kernel-name ( kernel -- string )
|
: 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 )
|
: 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 )
|
: cl-kernel-local-size ( kernel -- size )
|
||||||
(current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline
|
(current-cl-device) [ handle>> ] bi@ CL_KERNEL_WORK_GROUP_SIZE kernel-work-group-info-size_t ; inline
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue