extra/llvm/llvm.factor

   1 USING: accessors alien.c-types alien.strings arrays
   2 central destructors kernel llvm.core llvm.engine
   3 quotations sequences specialized-arrays.alien ;
   4
   5 IN: llvm
   6
   7 : llvm-throw ( char** -- )
   8     *void* [ alien>string ] [ LLVMDisposeMessage ] bi throw ;
   9
  10 DISPOSABLE-CENTRAL: module
  11 CENTRAL: function
  12 DISPOSABLE-CENTRAL: builder
  13 DISPOSABLE-CENTRAL: engine
  14
  15 : <dispose> ( alien class -- disposable ) new swap >>value ;
  16
  17 TUPLE: LLVMModule value disposed ;
  18 M: LLVMModule dispose* value>> LLVMDisposeModule ;
  19
  20 : <module> ( name -- module )
  21     LLVMModuleCreateWithName LLVMModule <dispose> ;
  22
  23 TUPLE: LLVMModuleProvider value disposed ;
  24 M: LLVMModuleProvider dispose* value>> LLVMDisposeModuleProvider ;
  25
  26 : <provider> ( -- module-provider )
  27     module t >>disposed value>> LLVMCreateModuleProviderForExistingModule
  28     LLVMModuleProvider <dispose> ;
  29
  30 : (add-block) ( name -- basic-block )
  31     function swap LLVMAppendBasicBlock ;
  32
  33 TUPLE: LLVMBuilder value disposed ;
  34 M: LLVMBuilder dispose* value>> LLVMDisposeBuilder ;
  35
  36 : <builder> ( name -- builder )
  37     (add-block) LLVMCreateBuilder [ swap LLVMPositionBuilderAtEnd ] keep
  38     LLVMBuilder <dispose> ;
  39
  40 TUPLE: LLVMExecutionEngine value disposed ;
  41 M: LLVMExecutionEngine dispose* value>> LLVMDisposeExecutionEngine ;
  42
  43 : <engine> ( -- engine )
  44     <provider> [
  45         dup value>> f <void*> f <void*>
  46         [ swapd 0 swap LLVMCreateJITCompiler drop ] 2keep
  47         *void* [ llvm-throw ] when* *void* LLVMExecutionEngine <dispose>
  48         swap t >>disposed drop
  49     ] with-disposal ;
  50
  51 : resolve-type ( callable/alien -- type )
  52     dup callable? [ call( -- type ) ] when ;
  53
  54 : <function-type> ( args -- type )
  55     [ resolve-type ] map
  56     unclip swap [ >void*-array ] keep length 0 LLVMFunctionType ;
  57
  58 : >>cc ( function calling-convention -- function )
  59     dupd LLVMSetFunctionCallConv ;
  60
  61 : params>> ( function -- array )
  62     dup LLVMCountParams "LLVMValueRef" <c-array> [ LLVMGetParams ] keep
  63     byte-array>void*-array >array ;
  64
  65 : get-param ( name -- value )
  66     function params>> swap [ swap LLVMGetValueName = ] curry find nip ;
  67
  68 : set-param-names ( names function -- )
  69     params>> swap [ LLVMSetValueName ] 2each ;
  70
  71 : <function> ( args -- function )
  72     module value>> over first second pick
  73     [ first ] map <function-type> LLVMAddFunction LLVMCCallConv >>cc tuck
  74     [ rest [ second ] map ] dip set-param-names ;
  75
  76 : global>pointer ( value -- alien ) engine value>> swap LLVMGetPointerToGlobal ;
  77
  78 : find-function ( name -- fn )
  79     engine value>> swap f <void*> [ LLVMFindFunction drop ] keep *void* ;
  80
  81 : llvm-int ( n -- Value )
  82     32 LLVMIntType swap 1 LLVMCreateGenericValueOfInt ;
  83
  84 : prepare-args ( function seq -- f numargs args )
  85     over LLVMCountParams swap [ llvm-int ] map f suffix >void*-array ;