VSL - The compiler.llvm.core Structure

# Copyright 2011  Petter Urkedal
#
# This file is part of the Viz Standard Library <http://www.vizlang.org/>.
#
# The Viz Standard Library (VSL) is free software: you can redistribute it
# and/or modify it under the terms of the GNU Lesser General Public License as
# published by the Free Software Foundation, either version 3 of the License,
# or (at your option) any later version.
#
# The VSL is distributed in the hope that it will be useful, but WITHOUT ANY
# WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public License for
# more details.
#
# You should have received a copy of the GNU Lesser General Public License
# along with the VSL.  If not, see <http://www.gnu.org/licenses/>.

open:c "llvm-c/Core.h"
open:c "compiler/llvm_suppl.h"
open pervasive
open effect
open foreign.cabi.memory


# Z.  LLVM Core API

# Z.Z.  Auxiliary Types

in iorder
    type t := int
    val:c EQ  : t := "LLVMIntEQ"
    val:c NE  : t := "LLVMIntNE"
    val:c UGT : t := "LLVMIntUGT"
    val:c UGE : t := "LLVMIntUGE"
    val:c ULT : t := "LLVMIntULT"
    val:c ULE : t := "LLVMIntULE"
    val:c SGT : t := "LLVMIntSGT"
    val:c SGE : t := "LLVMIntSGE"
    val:c SLT : t := "LLVMIntSLT"
    val:c SLE : t := "LLVMIntSLE"

type iorder := iorder.t

in forder
    type t
    inj:c FALSE : t := "LLVMRealPredicateFalse"
    inj:c OEQ : t := "LLVMRealOEQ"
    inj:c OGT : t := "LLVMRealOGT"
    inj:c OGE : t := "LLVMRealOGE"
    inj:c OLT : t := "LLVMRealOLT"
    inj:c OLE : t := "LLVMRealOLE"
    inj:c ONE : t := "LLVMRealONE"
    inj:c ORD : t := "LLVMRealORD"
    inj:c UNO : t := "LLVMRealUNO"
    inj:c UEQ : t := "LLVMRealUEQ"
    inj:c UGT : t := "LLVMRealUGT"
    inj:c UGE : t := "LLVMRealUGE"
    inj:c ULT : t := "LLVMRealULT"
    inj:c ULE : t := "LLVMRealULE"
    inj:c UNE : t := "LLVMRealUNE"
    inj:c TRUE : t := "LLVMRealPredicateTrue"

type forder := forder.t


# Z.Z.  Contexts

type:c context φ := "LLVMContextRef"

val:c create_context : φ /~ context φ := "LLVMContextCreate"

val:c global_context : world /~ context world := "LLVMGetGlobalContext"

val:cf dispose_context : context φ  φ /~ unit := "LLVMContextDispose"


# Z.Z.  Modules

type:c module φ := "LLVMModuleRef"

val create_module : context φ  string  φ /~ module φ

val:cf dispose_module : module φ  φ /~ unit := "LLVMDisposeModule"

val:c get_data_layout : module φ  φ /~ string := "LLVMGetDataLayout"

val:c set_data_layout : module φ  string  φ /~ unit := "LLVMSetDataLayout"

val:c get_target : module φ  φ /~ string := "LLVMGetTarget"

val:c set_target : module φ  string  φ /~ unit := "LLVMSetTarget"

val:c dump_module : module φ  φ /~ unit := "LLVMDumpModule"

val:c set_module_inline_asm : module φ  string  φ /~ unit
    := "LLVMSetModuleInlineAsm"


val:c _create_module : string  context φ  φ /~ module φ
    := "LLVMModuleCreateWithNameInContext"
let create_module ctx name be _create_module name ctx

val:c assert_valid_module : module φ  φ /~ unit := "LLVMAssertValidModule"


# Z.Z.  Types

type lkind
 inj:c lkind_void	:= "LLVMVoidTypeKind"
 inj:c lkind_half	:= "LLVMHalfTypeKind"
 inj:c lkind_float	:= "LLVMFloatTypeKind"
 inj:c lkind_double	:= "LLVMDoubleTypeKind"
 inj:c lkind_x86_fp80	:= "LLVMX86_FP80TypeKind"
 inj:c lkind_fp128	:= "LLVMFP128TypeKind"
 inj:c lkind_ppc_fp128	:= "LLVMPPC_FP128TypeKind"
 inj:c lkind_label	:= "LLVMLabelTypeKind"
 inj:c lkind_integer	:= "LLVMIntegerTypeKind"
 inj:c lkind_function	:= "LLVMFunctionTypeKind"
 inj:c lkind_struct	:= "LLVMStructTypeKind"
 inj:c lkind_array	:= "LLVMArrayTypeKind"
 inj:c lkind_pointer	:= "LLVMPointerTypeKind"
 inj:c lkind_vector	:= "LLVMVectorTypeKind"
 inj:c lkind_metadata	:= "LLVMMetadataTypeKind"
 inj:c lkind_mmx	:= "LLVMX86_MMXTypeKind"

type:c ltype φ := "LLVMTypeRef"

val:c type_kind : ltype φ  lkind#e := "LLVMGetTypeKind"
val:c type_context : ltype φ  context φ := "LLVMGetTypeContext"

val:c int1_type : context φ  ltype φ := "LLVMInt1TypeInContext"
val:c int8_type : context φ  ltype φ := "LLVMInt8TypeInContext"
val:c int16_type : context φ  ltype φ := "LLVMInt16TypeInContext"
val:c int32_type : context φ  ltype φ := "LLVMInt32TypeInContext"
val:c int64_type : context φ  ltype φ := "LLVMInt64TypeInContext"
val:c int_type : context φ  int  ltype φ := "LLVMIntTypeInContext"

val:c float_type : context φ  ltype φ := "LLVMFloatTypeInContext"
val:c double_type : context φ  ltype φ := "LLVMDoubleTypeInContext"
val:c x86_fp80_type : context φ  ltype φ := "LLVMX86FP80TypeInContext"
val:c fp128_type : context φ  ltype φ := "LLVMFP128TypeInContext"
val:c ppc_fp128_type : context φ  ltype φ := "LLVMPPCFP128TypeInContext"


# Z.Z.  Values

type:c value φ := "LLVMValueRef"

type:c memorybuffer φ := "LLVMMemoryBufferRef"


# Z.Z.Z.  Operations on Values

val:c type_of : value φ  φ /~ ltype φ := "LLVMTypeOf"

val:c get_value_name : value φ  φ /~ string := "LLVMGetValueName"

val:c set_value_name : value φ  string  φ /~ unit := "LLVMSetValueName"

val:c dump_value : value φ  φ /~ unit := "LLVMDumpValue"


# Z.Z.Z.  Operations on Uses


# Z.Z.Z.  Operations on Users


# Z.Z.Z.  Operations on Constants of any Type


# Z.Z.Z.  Operations on Metadata


# Z.Z.Z.  Operations on Scalar Constants

val const_int : ltype φ  int  φ /~ value φ

val const_int_of_int64 : ltype φ  int64  φ /~ value φ

val:c const_int_of_string : ltype φ  string  int  φ /~ value φ
    := "LLVMConstIntOfString"

val:c const_float : ltype φ  float  φ /~ value φ := "LLVMConstReal"

val:c const_float_of_string : ltype φ  string  φ /~ value φ
    := "LLVMConstRealOfString"

val:c _const_int : ltype φ  int  bool  φ /~ value φ := "LLVMConstInt"
let const_int t x be _const_int t x true
val:c _const_int64 : ltype φ  int64  bool  φ /~ value φ := "LLVMConstInt"
let const_int_of_int64 t x be _const_int64 t x true


# Z.Z.Z.  Operations on Composite Constants


# Z.Z.Z.  Constant Expressions


# Z.Z.Z.  Operations on Global Variables, Functions, and Aliases


# Z.Z.Z.  Operations on Global Variables


# Z.Z.Z.  Operations on Aliases


# Z.Z.Z.  Operations on Functions

type callconv := int
val:c callconv_c	: int := "LLVMCCallConv"
val:c callconv_fast	: int := "LLVMFastCallConv"
val:c callconv_cold	: int := "LLVMColdCallConv"
val:c callconv_x86_std	: int := "LLVMX86StdcallCallConv"
val:c callconv_x86_fast	: int := "LLVMX86FastcallCallConv"


val:c add_function : module φ  string  ltype φ  φ /~ value φ
    := "LLVMAddFunction"

val:c get_named_function : module φ  string  φ /~ option (value φ)
    := "LLVMGetNamedFunction"

val:c get_first_function : module φ  φ /~ option (value φ)
    := "LLVMGetFirstFunction"

val:c get_last_function : module φ  φ /~ option (value φ)
    := "LLVMGetLastFunction"

val:c get_next_function : value φ  φ /~ option (value φ)
    := "LLVMGetNextFunction"

val:c get_prev_function : value φ  φ /~ option (value φ)
    := "LLVMGetPreviousFunction"

val:c delete_function : value φ  φ /~ unit
    := "LLVMDeleteFunction"

val:c get_function_callconv : value φ  φ /~ int
    := "LLVMGetFunctionCallConv"

val:c set_function_callconv : value φ  int  φ /~ unit
    := "LLVMSetFunctionCallConv"

val:c get_function_gc : value φ  φ /~ option string := "LLVMGetGC"

val:c set_function_gc : value φ  string  φ /~ unit := "LLVMSetGC"

val function_type : ltype φ  array (ltype φ)  ltype φ

val:c _function_type : ltype φ  ptr φ  int  bool  ltype φ
    := "LLVMFunctionType"
let function_type rt ats be unsafe_observe what!
    let cta do foreign.cabi.utils.malloc_ptrarray_of_array ats
    let r be _function_type rt cta (array.length ats) false
    do unsafe_free cta
    be r


# Z.Z.Z.  Operations on Parameters

val:c arity : value φ  int := "LLVMCountParams"

val:c param : value φ  int  value φ := "LLVMGetParam"


# Z.Z.Z.  Operations on Basic Blocks

type:c block φ := "LLVMBasicBlockRef"

val:c value_of_block : block φ  value φ := "LLVMBasicBlockAsValue"

val:c value_is_block : value φ  bool := "LLVMValueIsBasicBlock"

val:c value_to_block : value φ  block φ := "LLVMValueAsBasicBlock"

val:c get_block_parent : block φ  φ /~ value φ := "LLVMGetBasicBlockParent"

val:c block_count : value φ  φ /~ int := "LLVMCountBasicBlocks"

val:c first_block : value φ  φ /~ block φ := "LLVMGetFirstBasicBlock"

val:c last_block : value φ  φ /~ block φ := "LLVMGetLastBasicBlock"

val:c next_block : block φ  φ /~ block φ := "LLVMGetNextBasicBlock"

val:c prev_block : block φ  φ /~ block φ := "LLVMGetPreviousBasicBlock"

val:c entry_block : value φ  φ /~ block φ := "LLVMGetEntryBasicBlock"

val:c append_block : context φ  value φ  string  φ /~ block φ
    := "LLVMAppendBasicBlockInContext"

val:c insert_block : context φ  block φ  string  φ /~ block φ
    := "LLVMInsertBasicBlockInContext"

val:c delete_block : block φ  φ /~ unit
    := "LLVMDeleteBasicBlock"

val:c move_block_before : block φ  block φ  φ /~ unit
    := "LLVMMoveBasicBlockBefore"

val:c move_block_after : block φ  block φ  φ /~ unit
    := "LLVMMoveBasicBlockAfter"


# Z.Z.  Instruction Builders

type:c builder φ := "LLVMBuilderRef"

val:c create_builder : context φ  φ /~ builder φ
    := "LLVMCreateBuilderInContext"

val:c position_builder : builder φ  block φ  value φ  φ /~ unit
    := "LLVMPositionBuilder"

val:c position_builder_before : builder φ  value φ  φ /~ unit
    := "LLVMPositionBuilderBefore"

val:c position_builder_at_end : builder φ  block φ  φ /~ unit
    := "LLVMPositionBuilderAtEnd"

val:c get_insert_block : builder φ  φ /~ block φ
    := "LLVMGetInsertBlock"

val:c clear_insertion_position : builder φ  φ /~ unit
    := "LLVMClearInsertionPosition"

val:c insert_into_builder : builder φ  value φ  string  φ /~ unit
    := "LLVMInsertIntoBuilderWithName"

val:cf dispose_builder : builder φ  φ /~ unit
    := "LLVMDisposeBuilder"

# Z.Z.Z.  Metadata

val:c set_current_debug_location : builder φ  value φ  φ /~ unit
    := "LLVMSetCurrentDebugLocation"

val:c get_current_debug_location : builder φ  φ /~ value φ
    := "LLVMGetCurrentDebugLocation"

val:c set_inst_debug_location : builder φ  value φ  φ /~ unit
    := "LLVMSetInstDebugLocation"


# Z.Z.Z.  Terminators

val:c build_ret_void : builder φ  φ /~ value φ := "LLVMBuildRetVoid"

val:c build_ret : builder φ  value φ  φ /~ value φ := "LLVMBuildRet"

val build_aggregate_ret : builder φ  array (value φ)  φ /~ value φ

val:c build_br : builder φ  block φ  φ /~ value φ := "LLVMBuildBr"

val:c build_cond_br : builder φ  value φ  block φ  block φ  φ /~ value φ
    := "LLVMBuildCondBr"

val:c build_switch : builder φ  value φ  block φ  int  φ /~ value φ
    := "LLVMBuildSwitch"

val:c add_case : value φ  value φ  block φ  φ /~ unit
    := "LLVMAddCase"

val:c build_indirect_br : builder φ  value φ  int  φ /~ value φ
    := "LLVMBuildIndirectBr"

val:c add_destination : value φ  block φ  φ /~ unit
    := "LLVMAddDestination"

val build_invoke :
    builder φ  value φ  array (value φ)  block φ  block φ  string 
    φ /~ value φ

val:c build_resume : builder φ  value φ  φ /~ value φ := "LLVMBuildResume"

val:c build_unreachable : builder φ  φ /~ value φ := "LLVMBuildUnreachable"


val:c _build_aggregate_ret : builder φ  ptr φ  int  φ /~ value φ
    := "LLVMBuildAggregateRet"
let! build_aggregate_ret b xa
    let ca do foreign.cabi.utils.malloc_ptrarray_of_array xa
    let r do _build_aggregate_ret b ca (array.length xa)
    do unsafe_free ca
    be r

val:c _build_invoke :
    builder φ  value φ  ptr φ  int  block φ  block φ  string  φ /~ value φ
    := "LLVMBuildInvoke"
let! build_invoke b f args bb unwind_bb name
    let cargs do foreign.cabi.utils.malloc_ptrarray_of_array args
    let r do _build_invoke b f cargs (array.length args) bb unwind_bb name
    do unsafe_free cargs
    be r


# Z.Z.Z.  Arithmetic

val:c build_add : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildAdd"
val:c build_nsw_add : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildNSWAdd"
val:c build_nuw_add : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildNUWAdd"
val:c build_fadd : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildFAdd"

val:c build_sub : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildSub"
val:c build_nsw_sub : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildNSWSub"
val:c build_nuw_sub : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildNUWSub"
val:c build_fsub : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildFSub"

val:c build_mul : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildMul"
val:c build_nsw_mul : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildNSWMul"
val:c build_nuw_mul : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildNUWMul"
val:c build_fmul : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildFMul"

val:c build_udiv : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildUDiv"
val:c build_sdiv : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildSDiv"
val:c build_exact_sdiv : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildExactSDiv"
val:c build_fdiv : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildFDiv"

val:c build_urem : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildURem"
val:c build_srem : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildSRem"
val:c build_frem : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildFRem"

val:c build_shl : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildShl"
val:c build_lshr : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildLShr"
val:c build_ashr : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildAShr"

val:c build_and : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildAnd"
val:c build_or : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildOr"
val:c build_xor : builder φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildXor"

val:c build_neg : builder φ  value φ  string  φ /~ value φ
    := "LLVMBuildNeg"
val:c build_nsw_neg : builder φ  value φ  string  φ /~ value φ
    := "LLVMBuildNSWNeg"
val:c build_nuw_neg : builder φ  value φ  string  φ /~ value φ
    := "LLVMBuildNUWNeg"
val:c build_fneg : builder φ  value φ  string  φ /~ value φ
    := "LLVMBuildFNeg"

val:c build_not : builder φ  value φ  string  φ /~ value φ
    := "LLVMBuildNot"


# Z.Z.Z.  Memory


# Z.Z.Z.  Casts


# Z.Z.Z.  Comparisons

val:c build_icmp :
    builder φ  iorder#i  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildICmp"

val:c build_fcmp :
    builder φ  forder#e  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildFCmp"


# Z.Z.Z.  Miscellaneous Instructions

val:c build_phi : builder φ  ltype φ  string  φ /~ value φ
    := "LLVMBuildPhi"

val add_incoming : value φ  array (value φ × block φ)  φ /~ unit

val build_call :
    builder φ  value φ  array (value φ)  string  φ /~ value φ

val:c build_select :
    builder φ  value φ  value φ  value φ  string  φ /~ value φ
    := "LLVMBuildSelect"


val:c _build_call :
    builder φ  value φ  ptr φ  int  string  φ /~ value φ
    := "LLVMBuildCall"
let! build_call b f args name
    let cargs do foreign.cabi.utils.malloc_ptrarray_of_array args
    let r do _build_call b f cargs (array.length args) name
    do unsafe_free cargs
    be r

val:c _add_incoming : value φ  ptr φ  ptr φ  int  φ /~ unit
    := "LLVMAddIncoming"
let! add_incoming phi incoming
    let n be array.length incoming
    let cva do foreign.cabi.utils.malloc_ptrarray_init n
		(i  unsafe_custom_load_ptr (fst (array.get i incoming)))
    let cba do foreign.cabi.utils.malloc_ptrarray_init n
		(i  unsafe_custom_load_ptr (snd (array.get i incoming)))
    do _add_incoming phi cva cba n


# Z.Z.  Module Providers

in module_provider
    type:c t φ := "LLVMModuleProviderRef"

    val:c create_for : module φ  φ /~ t φ
	:= "LLVMCreateModuleProviderForExistingModule"

    val:c dispose : t φ  φ /~ unit := "LLVMDisposeModuleProvider"


# Z.Z.  Pass Managers

type function_ph inj _function_ph
type module_ph   inj _module_ph
type:c pass_manager μ φ := "LLVMPassManagerRef"

in module_pass_manager
    type t φ := pass_manager module_ph φ

    val:c create : φ /~ t φ := "LLVMCreatePassManager"

    val:c run : t φ  module φ  φ /~ bool := "LLVMRunPassManager"

    val:c dispose : t φ  φ /~ unit := "LLVMDisposePassManager"

in function_pass_manager
    type t φ := pass_manager function_ph φ

    val:c create : module φ  φ /~ t φ
	:= "LLVMCreateFunctionPassManagerForModule"

    val:c initialize : t φ  φ /~ bool := "LLVMInitializeFunctionPassManager"

    val:c run : t φ  value φ  φ /~ bool := "LLVMRunFunctionPassManager"

    val:c finalize : t φ  φ /~ bool := "LLVMFinalizeFunctionPassManager"

    val:c dispose : t φ  φ /~ unit := "LLVMDisposePassManager"