1 ! Copyright (C) 2009 Matthew Willis.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors alien.c-types alien.data arrays combinators
4 kernel llvm.core locals math.parser math multiline namespaces
5 parser peg.ebnf sequences sequences.deep specialized-arrays
7 SPECIALIZED-ARRAY: void*
10 ! Type resolution strategy:
12 ! create the type with uprefs mapped to opaque types
13 ! cache typerefs in enclosing types for pass 2
14 ! if our type is concrete, then we are done
17 ! wrap our abstract type in a type handle
18 ! create a second type, using the cached enclosing type info
19 ! resolve the first type to the second
21 GENERIC: (>tref) ( type -- LLVMTypeRef )
22 GENERIC: ((tref>)) ( LLVMTypeRef type -- type )
23 GENERIC: c-type ( type -- str )
25 ! default implementation for simple types
26 M: object ((tref>)) nip ;
27 : unsupported-type ( -- )
28 "cannot generate c-type: unsupported llvm type" throw ;
29 M: object c-type unsupported-type ;
34 M: integer (>tref) size>> LLVMIntType ;
35 M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ;
36 M: integer c-type size>> {
44 SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
46 M: float (>tref) drop LLVMFloatType ;
47 M: double (>tref) drop LLVMDoubleType ;
48 M: double c-type drop "double" ;
49 M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
50 M: fp128 (>tref) drop LLVMFP128Type ;
51 M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
53 SINGLETONS: opaque label void metadata ;
55 M: opaque (>tref) drop LLVMOpaqueType ;
56 M: label (>tref) drop LLVMLabelType ;
57 M: void (>tref) drop LLVMVoidType ;
58 M: void c-type drop "void" ;
59 M: metadata (>tref) drop
60 "metadata types unsupported by llvm c bindings" throw ;
62 ! enclosing types cache their llvm refs during
63 ! the first pass, used in the second pass to
65 TUPLE: enclosing cached ;
67 GENERIC: clean ( type -- )
68 GENERIC: clean* ( type -- )
69 M: object clean drop ;
70 M: enclosing clean f >>cached clean* ;
72 ! builds the stack of types that uprefs need to refer to
74 :: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
76 type quot call( type -- LLVMTypeRef )
77 types get pop over >>cached drop ;
80 :: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type )
82 [ types get length swap - <up-ref> ] [
84 ref quot call( LLVMTypeRef -- type )
88 GENERIC: (>tref)* ( type -- LLVMTypeRef )
89 M: enclosing (>tref) [ (>tref)* ] push-type ;
92 GENERIC: (tref>)* ( LLVMTypeRef type -- type )
93 M: enclosing ((tref>)) [ (tref>)* ] curry push-ref ;
95 : (tref>) ( LLVMTypeRef -- type ) dup type-kind ((tref>)) ;
97 TUPLE: pointer < enclosing type ;
98 : <pointer> ( t -- o ) pointer new swap >>type ;
100 M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
101 M: pointer clean* type>> clean ;
102 M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ;
103 M: pointer c-type type>> 8 <integer> = "c-string" "void*" ? ;
105 TUPLE: vector < enclosing size type ;
106 : <vector> ( s t -- o )
108 swap >>type swap >>size ;
110 M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
111 M: vector clean* type>> clean ;
113 over LLVMGetElementType (tref>) >>type
114 swap LLVMGetVectorSize >>size ;
116 TUPLE: struct < enclosing types packed? ;
117 : <struct> ( ts p? -- o )
119 swap >>packed? swap >>types ;
122 [ types>> [ (>tref) ] map void* >c-array ]
124 [ packed?>> 1 0 ? ] tri LLVMStructType ;
125 M: struct clean* types>> [ clean ] each ;
127 over LLVMIsPackedStruct 0 = not >>packed?
128 swap dup LLVMCountStructElementTypes void* <c-array>
129 [ LLVMGetStructElementTypes ] keep >array
130 [ (tref>) ] map >>types ;
132 TUPLE: array < enclosing size type ;
133 : <array> ( s t -- o )
135 swap >>type swap >>size ;
137 M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
138 M: array clean* type>> clean ;
140 over LLVMGetElementType (tref>) >>type
141 swap LLVMGetArrayLength >>size ;
144 TUPLE: function < enclosing return params vararg? ;
145 : <function> ( ret params var? -- o )
147 swap >>vararg? swap >>params swap >>return ;
149 M: function (>tref)* {
151 [ params>> [ (>tref) ] map void* >c-array ]
154 } cleave LLVMFunctionType ;
155 M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
157 over LLVMIsFunctionVarArg 0 = not >>vararg?
158 over LLVMGetReturnType (tref>) >>return
159 swap dup LLVMCountParamTypes void* <c-array>
160 [ LLVMGetParamTypes ] keep >array
161 [ (tref>) ] map >>params ;
163 : type-kind ( LLVMTypeRef -- class )
165 { LLVMVoidTypeKind [ void ] }
166 { LLVMFloatTypeKind [ float ] }
167 { LLVMDoubleTypeKind [ double ] }
168 { LLVMX86_FP80TypeKind [ x86_fp80 ] }
169 { LLVMFP128TypeKind [ fp128 ] }
170 { LLVMPPC_FP128TypeKind [ ppc_fp128 ] }
171 { LLVMLabelTypeKind [ label ] }
172 { LLVMIntegerTypeKind [ integer new ] }
173 { LLVMFunctionTypeKind [ function new ] }
174 { LLVMStructTypeKind [ struct new ] }
175 { LLVMArrayTypeKind [ array new ] }
176 { LLVMPointerTypeKind [ pointer new ] }
177 { LLVMOpaqueTypeKind [ opaque ] }
178 { LLVMVectorTypeKind [ vector new ] }
181 TUPLE: up-ref height ;
185 types get length swap height>> - types get nth
186 cached>> [ LLVMOpaqueType ] unless* ;
188 : resolve-types ( typeref typeref -- typeref )
189 over LLVMCreateTypeHandle [ LLVMRefineType ] dip
190 [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
192 : >tref-caching ( type -- LLVMTypeRef )
193 V{ } clone types [ (>tref) ] with-variable ;
195 : >tref ( type -- LLVMTypeRef )
196 [ >tref-caching ] [ >tref-caching ] [ clean ] tri
197 2dup = [ drop ] [ resolve-types ] if ;
199 : tref> ( LLVMTypeRef -- type )
200 V{ } clone types [ (tref>) ] with-variable ;
204 "type-info" LLVMModuleCreateWithName
205 [ "t" rot LLVMAddTypeName drop ]
207 [ LLVMDisposeModule ] tri ;
213 Zero = "0" => [[ drop 0 ]]
216 Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]]
217 WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]]
218 WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]]
220 Integer = "i" Number:n => [[ n <integer> ]]
221 FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup-word ]]
222 LabelVoidMetadata = ( "label" | "void" | "metadata" | "opaque" ) => [[ "llvm.types" vocab lookup-word ]]
223 Primitive = LabelVoidMetadata | FloatingPoint
224 Pointer = T:t WhiteSpace "*" => [[ t <pointer> ]]
225 Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
226 StructureTypesList = "," Type:t => [[ t ]]
227 Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
228 Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
229 NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]]
230 VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
231 ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
232 ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
233 Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts remove! drop ] when t ts >array rot <function> ]]
234 PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
235 UpReference = "\\" Number:n => [[ n <up-ref> ]]
236 Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
238 T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
240 Type = WhiteSpace T:t WhiteSpace => [[ t ]]
246 SYNTAX: TYPE: ";" parse-multiline-string parse-type suffix! ;