56 lines
		
	
	
		
			1.8 KiB
		
	
	
	
		
			Factor
		
	
	
			
		
		
	
	
			56 lines
		
	
	
		
			1.8 KiB
		
	
	
	
		
			Factor
		
	
	
! Copyright (C) 2009 Matthew Willis.
 | 
						|
! See http://factorcode.org/license.txt for BSD license.
 | 
						|
USING: accessors alien arrays assocs compiler.units effects
 | 
						|
io.backend io.pathnames kernel llvm.core llvm.jit llvm.reader
 | 
						|
llvm.types make namespaces sequences specialized-arrays
 | 
						|
vocabs words ;
 | 
						|
SPECIALIZED-ARRAY: void*
 | 
						|
IN: llvm.invoker
 | 
						|
 | 
						|
! get function name, ret type, param types and names
 | 
						|
 | 
						|
! load module
 | 
						|
! iterate through functions in a module
 | 
						|
 | 
						|
TUPLE: function name alien return params ;
 | 
						|
 | 
						|
: params ( llvm-function -- param-list )
 | 
						|
    dup LLVMCountParams <void*-array>
 | 
						|
    [ LLVMGetParams ] keep >array
 | 
						|
    [ [ LLVMGetValueName ] [ LLVMTypeOf tref> ] bi 2array ] map ;
 | 
						|
 | 
						|
: <function> ( LLVMValueRef -- function )
 | 
						|
    function new
 | 
						|
    over LLVMGetValueName >>name
 | 
						|
    over LLVMTypeOf tref> type>> return>> >>return
 | 
						|
    swap params >>params ;
 | 
						|
 | 
						|
: (functions) ( llvm-function -- )
 | 
						|
    [ dup , LLVMGetNextFunction (functions) ] when* ;
 | 
						|
 | 
						|
: functions ( llvm-module -- functions )
 | 
						|
    LLVMGetFirstFunction [ (functions) ] { } make [ <function> ] map ;
 | 
						|
 | 
						|
: function-effect ( function -- effect )
 | 
						|
    [ params>> [ first ] map ] [ return>> void? 0 1 ? ] bi <effect> ;
 | 
						|
 | 
						|
: install-function ( function -- )
 | 
						|
    dup name>> "alien.llvm" create-vocab drop
 | 
						|
    "alien.llvm" create swap
 | 
						|
    [
 | 
						|
        dup name>> function-pointer ,
 | 
						|
        dup return>> c-type ,
 | 
						|
        dup params>> [ second c-type ] map ,
 | 
						|
        cdecl , \ alien-indirect ,
 | 
						|
    ] [ ] make swap function-effect [ define-declared ] with-compilation-unit ;
 | 
						|
 | 
						|
: install-module ( name -- )
 | 
						|
    current-jit mps>> at [
 | 
						|
        module>> functions [ install-function ] each
 | 
						|
    ] [ "no such module" throw ] if* ;
 | 
						|
 | 
						|
: install-bc ( path -- )
 | 
						|
    [ normalize-path ] [ file-name ] bi
 | 
						|
    [ load-into-jit ] keep install-module ;
 | 
						|
    
 | 
						|
<< "alien.llvm" create-vocab drop >> |