Added type parser, factor llvm type objects, and recursive type resolution

extra/llvm/core/core.factor

@@ -115,6 +115,8 @@ TYPEDEF: void* LLVMModuleProviderRef
 
 TYPEDEF: void* LLVMTypeRef
 
+TYPEDEF: void* LLVMTypeHandleRef
+
 TYPEDEF: void* LLVMValueRef
 
 TYPEDEF: void* LLVMBasicBlockRef
@@ -138,13 +140,78 @@ LLVMCreateModuleProviderForExistingModule ( LLVMModuleRef M ) ;
 
 FUNCTION: void LLVMDisposeModuleProvider ( LLVMModuleProviderRef MP ) ;
 
-FUNCTION: LLVMTypeRef LLVMIntType ( unsigned NumBits ) ;
+! Types
 
+! LLVM types conform to the following hierarchy:
+!  
+!    types:
+!      integer type
+!      real type
+!      function type
+!      sequence types:
+!        array type
+!        pointer type
+!        vector type
+!      void type
+!      label type
+!      opaque type
+
+! See llvm::LLVMTypeKind::getTypeID.
+FUNCTION: LLVMTypeKind LLVMGetTypeKind ( LLVMTypeRef Ty ) ;
+
+! Operations on integer types
+FUNCTION: LLVMTypeRef LLVMInt1Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt8Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt16Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt32Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMInt64Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMIntType ( unsigned NumBits ) ;
+FUNCTION: unsigned LLVMGetIntTypeWidth ( LLVMTypeRef IntegerTy ) ;
+
+! Operations on real types
+FUNCTION: LLVMTypeRef LLVMFloatType ( ) ;
+FUNCTION: LLVMTypeRef LLVMDoubleType ( ) ;
+FUNCTION: LLVMTypeRef LLVMX86FP80Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMFP128Type ( ) ;
+FUNCTION: LLVMTypeRef LLVMPPCFP128Type ( ) ;
+
+! Operations on function types
 FUNCTION: LLVMTypeRef
-LLVMFunctionType ( LLVMTypeRef ReturnType,
+LLVMFunctionType ( LLVMTypeRef ReturnType, LLVMTypeRef* ParamTypes, unsigned ParamCount, int IsVarArg ) ;
-                   LLVMTypeRef* ParamTypes,
+FUNCTION: int LLVMIsFunctionVarArg ( LLVMTypeRef FunctionTy ) ;
-                   unsigned ParamCount,
+FUNCTION: LLVMTypeRef LLVMGetReturnType ( LLVMTypeRef FunctionTy ) ;
-                   int IsVarArg ) ;
+FUNCTION: unsigned LLVMCountParamTypes ( LLVMTypeRef FunctionTy ) ;
+FUNCTION: void LLVMGetParamTypes ( LLVMTypeRef FunctionTy, LLVMTypeRef* Dest ) ;
+
+! Operations on struct types
+FUNCTION: LLVMTypeRef
+LLVMStructType ( LLVMTypeRef* ElementTypes, unsigned ElementCount, int Packed ) ;
+FUNCTION: unsigned LLVMCountStructElementTypes ( LLVMTypeRef StructTy ) ;
+FUNCTION: void LLVMGetStructElementTypes ( LLVMTypeRef StructTy, LLVMTypeRef* Dest ) ;
+FUNCTION: int LLVMIsPackedStruct ( LLVMTypeRef StructTy ) ;
+
+! Operations on array, pointer, and vector types (sequence types)
+FUNCTION: LLVMTypeRef LLVMArrayType ( LLVMTypeRef ElementType, unsigned ElementCount ) ;
+FUNCTION: LLVMTypeRef LLVMPointerType ( LLVMTypeRef ElementType, unsigned AddressSpace ) ;
+FUNCTION: LLVMTypeRef LLVMVectorType ( LLVMTypeRef ElementType, unsigned ElementCount ) ;
+
+FUNCTION: LLVMTypeRef LLVMGetElementType ( LLVMTypeRef Ty ) ;
+FUNCTION: unsigned LLVMGetArrayLength ( LLVMTypeRef ArrayTy ) ;
+FUNCTION: unsigned LLVMGetPointerAddressSpace ( LLVMTypeRef PointerTy ) ;
+FUNCTION: unsigned LLVMGetVectorSize ( LLVMTypeRef VectorTy ) ;
+
+! Operations on other types
+FUNCTION: LLVMTypeRef LLVMVoidType ( ) ;
+FUNCTION: LLVMTypeRef LLVMLabelType ( ) ;
+FUNCTION: LLVMTypeRef LLVMOpaqueType ( ) ;
+
+! Operations on type handles
+FUNCTION: LLVMTypeHandleRef LLVMCreateTypeHandle ( LLVMTypeRef PotentiallyAbstractTy ) ;
+FUNCTION: void LLVMRefineType ( LLVMTypeRef AbstractTy, LLVMTypeRef ConcreteTy ) ;
+FUNCTION: LLVMTypeRef LLVMResolveTypeHandle ( LLVMTypeHandleRef TypeHandle ) ;
+FUNCTION: void LLVMDisposeTypeHandle ( LLVMTypeHandleRef TypeHandle ) ;
+
+! Types end
 
 FUNCTION: unsigned LLVMCountParams ( LLVMValueRef Fn ) ;
 

extra/llvm/types/types-tests.factor

@@ -0,0 +1,20 @@
+USING: kernel llvm.types sequences tools.test ;
+
+[ T{ integer f 32 }  ] [ " i32 " parse-type ] unit-test
+[ float ] [ " float " parse-type ] unit-test
+[ T{ pointer f f x86_fp80 } ] [ " x86_fp80 * " parse-type ] unit-test
+[ T{ vector f f 4 T{ integer f 32 } } ] [ " < 4 x i32 > " parse-type ] unit-test
+[ T{ struct f f { float double } f } ] [ TYPE: { float , double } ; ] unit-test
+[ T{ array f f 0 float } ] [ TYPE: [ 0 x float ] ; ] unit-test
+
+[ label void metadata ]
+[ [ " label " " void " " metadata " ] [ parse-type ] each ] unit-test
+
+[ T{ function f f float { float float } t } ]
+[ TYPE: float ( float , float , ... ) ; ] unit-test
+
+[ T{ struct f f { float TYPE: i32 (i32)* ; } t } ]
+[ TYPE: < { float, i32 (i32)* } > ; ] unit-test
+
+[ t ] [ TYPE: i32 ; TYPE: i32 ; [ >tref ] bi@ = ] unit-test
+[ t ] [ TYPE: i32 * ; TYPE: i32 * ; [ >tref ] bi@ = ] unit-test

extra/llvm/types/types.factor

@@ -0,0 +1,172 @@
+USING: accessors arrays combinators kernel llvm.core
+locals math.parser math multiline
+namespaces parser peg.ebnf sequences
+sequences.deep specialized-arrays.alien strings vocabs words ;
+
+IN: llvm.types
+
+! Type resolution strategy:
+!  pass 1:
+!    create the type with uprefs mapped to opaque types
+!    cache typerefs in enclosing types for pass 2
+!    if our type is concrete, then we are done
+!
+!  pass 2:
+!    wrap our abstract type in a type handle
+!    create a second type, using the cached enclosing type info
+!    resolve the first type to the second
+!
+GENERIC: (>tref) ( type -- LLVMTypeRef )
+
+GENERIC: llvm> ( LLVMTypeRef -- type )
+
+TUPLE: integer size ;
+C: <integer> integer
+
+M: integer (>tref) size>> LLVMIntType ;
+
+SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
+
+M: float (>tref) drop LLVMFloatType ;
+M: double (>tref) drop LLVMDoubleType ;
+M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
+M: fp128 (>tref) drop LLVMFP128Type ;
+M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
+
+SINGLETONS: label void metadata ;
+
+M: label (>tref) drop LLVMLabelType ;
+M: void (>tref) drop LLVMVoidType ;
+M: metadata (>tref) drop
+    "metadata types unsupported by llvm c bindings" throw ;
+
+! enclosing types cache their llvm refs during
+! the first pass, used in the second pass to
+! resolve uprefs
+TUPLE: enclosing cached ;
+
+GENERIC: clean ( type -- )
+GENERIC: clean* ( type -- )
+M: object clean drop ;
+M: enclosing clean f >>cached clean* ;
+
+! builds the stack of types that uprefs need to refer to
+SYMBOL: types
+:: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
+    type types get push
+    type quot call( type -- LLVMTypeRef )
+    types get pop over >>cached drop ;
+
+GENERIC: (>tref)* ( type -- LLVMTypeRef )
+M: enclosing (>tref) [ (>tref)* ] push-type ;
+
+TUPLE: pointer < enclosing type ;
+: <pointer> ( t -- o ) pointer new swap >>type ;
+
+M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
+M: pointer clean* type>> clean ;
+
+TUPLE: vector < enclosing size type ;
+: <vector> ( s t -- o )
+    vector new
+    swap >>type swap >>size ;
+
+M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
+M: vector clean* type>> clean ;
+
+TUPLE: struct < enclosing types packed? ;
+: <struct> ( ts p? -- o )
+    struct new
+    swap >>packed? swap >>types ;
+
+M: struct (>tref)*
+    [ types>> [ (>tref) ] map >void*-array ]
+    [ types>> length ]
+    [ packed?>> 1 0 ? ] tri LLVMStructType ;
+M: struct clean* types>> [ clean ] each ;
+
+TUPLE: array < enclosing size type ;
+: <array> ( s t -- o )
+    array new
+    swap >>type swap >>size ;
+
+M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
+M: array clean* type>> clean ;
+
+SYMBOL: ...
+TUPLE: function < enclosing return params vararg? ;
+: <function> ( ret params var? -- o )
+    function new
+    swap >>vararg? swap >>params swap >>return ;
+
+M: function (>tref)* {
+    [ return>> (>tref) ]
+    [ params>> [ (>tref) ] map >void*-array ]
+    [ params>> length ]
+    [ vararg?>> 1 0 ? ]
+} cleave LLVMFunctionType ;
+M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
+
+TUPLE: up-ref height ;
+C: <up-ref> up-ref
+
+M: up-ref (>tref)
+    types get length swap height>> - types get nth
+    cached>> [ LLVMOpaqueType ] unless* ;
+
+: resolve-types ( typeref typeref -- typeref )
+    over LLVMCreateTypeHandle [ LLVMRefineType ] dip
+    [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
+
+: >tref-caching ( type -- LLVMTypeRef )
+    V{ } clone types [ (>tref) ] with-variable ;
+
+: >tref ( type -- LLVMTypeRef )
+    [ >tref-caching ] [ >tref-caching ] [ clean ] tri
+    2dup = [ drop ] [ resolve-types ] if ;
+
+: t. ( type -- )
+    >tref
+    "type-info" LLVMModuleCreateWithName
+    [ "t" rot LLVMAddTypeName drop ]
+    [ LLVMDumpModule ]
+    [ LLVMDisposeModule ] tri ;
+
+EBNF: parse-type
+
+WhiteSpace = " "*
+
+Zero = "0" => [[ drop 0 ]]
+LeadingDigit = [1-9]
+DecimalDigit = [0-9]
+Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]]
+WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]]
+WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]]
+
+Integer = "i" Number:n => [[ n <integer> ]]
+FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]]
+LabelVoidMetadata = ( "label" | "void" | "metadata" ) => [[ "llvm.types" vocab lookup ]]
+Primitive = LabelVoidMetadata | FloatingPoint
+Pointer = T:t WhiteSpace "*" => [[ t <pointer> ]]
+Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
+StructureTypesList = "," Type:t => [[ t ]]
+Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
+Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
+NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]]
+VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
+ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
+ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
+Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot <function> ]]
+PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
+UpReference = "\\" Number:n => [[ n <up-ref> ]]
+Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
+
+T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
+
+Type = WhiteSpace T:t WhiteSpace => [[ t ]]
+
+Program = Type
+
+;EBNF
+
+SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ;