1 ! Copyright (C) 2009 Matthew Willis.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays combinators kernel llvm.core locals
4 math.parser math multiline namespaces parser peg.ebnf sequences
5 sequences.deep specialized-arrays strings vocabs words ;
6 SPECIALIZED-ARRAY: void*
9 ! Type resolution strategy:
11 ! create the type with uprefs mapped to opaque types
12 ! cache typerefs in enclosing types for pass 2
13 ! if our type is concrete, then we are done
16 ! wrap our abstract type in a type handle
17 ! create a second type, using the cached enclosing type info
18 ! resolve the first type to the second
20 GENERIC: (>tref) ( type -- LLVMTypeRef )
21 GENERIC: ((tref>)) ( LLVMTypeRef type -- type )
22 GENERIC: c-type ( type -- str )
24 ! default implementation for simple types
25 M: object ((tref>)) nip ;
26 : unsupported-type ( -- )
27 "cannot generate c-type: unsupported llvm type" throw ;
28 M: object c-type unsupported-type ;
33 M: integer (>tref) size>> LLVMIntType ;
34 M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ;
35 M: integer c-type size>> {
43 SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
45 M: float (>tref) drop LLVMFloatType ;
46 M: double (>tref) drop LLVMDoubleType ;
47 M: double c-type drop "double" ;
48 M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
49 M: fp128 (>tref) drop LLVMFP128Type ;
50 M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
52 SINGLETONS: opaque label void metadata ;
54 M: opaque (>tref) drop LLVMOpaqueType ;
55 M: label (>tref) drop LLVMLabelType ;
56 M: void (>tref) drop LLVMVoidType ;
57 M: void c-type drop "void" ;
58 M: metadata (>tref) drop
59 "metadata types unsupported by llvm c bindings" throw ;
61 ! enclosing types cache their llvm refs during
62 ! the first pass, used in the second pass to
64 TUPLE: enclosing cached ;
66 GENERIC: clean ( type -- )
67 GENERIC: clean* ( type -- )
68 M: object clean drop ;
69 M: enclosing clean f >>cached clean* ;
71 ! builds the stack of types that uprefs need to refer to
73 :: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
75 type quot call( type -- LLVMTypeRef )
76 types get pop over >>cached drop ;
79 :: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type )
81 [ types get length swap - <up-ref> ] [
83 ref quot call( LLVMTypeRef -- type )
87 GENERIC: (>tref)* ( type -- LLVMTypeRef )
88 M: enclosing (>tref) [ (>tref)* ] push-type ;
91 GENERIC: (tref>)* ( LLVMTypeRef type -- type )
92 M: enclosing ((tref>)) [ (tref>)* ] curry push-ref ;
94 : (tref>) ( LLVMTypeRef -- type ) dup type-kind ((tref>)) ;
96 TUPLE: pointer < enclosing type ;
97 : <pointer> ( t -- o ) pointer new swap >>type ;
99 M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
100 M: pointer clean* type>> clean ;
101 M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ;
102 M: pointer c-type type>> 8 <integer> = "char*" "void*" ? ;
104 TUPLE: vector < enclosing size type ;
105 : <vector> ( s t -- o )
107 swap >>type swap >>size ;
109 M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
110 M: vector clean* type>> clean ;
112 over LLVMGetElementType (tref>) >>type
113 swap LLVMGetVectorSize >>size ;
115 TUPLE: struct < enclosing types packed? ;
116 : <struct> ( ts p? -- o )
118 swap >>packed? swap >>types ;
121 [ types>> [ (>tref) ] map >void*-array ]
123 [ packed?>> 1 0 ? ] tri LLVMStructType ;
124 M: struct clean* types>> [ clean ] each ;
126 over LLVMIsPackedStruct 0 = not >>packed?
127 swap dup LLVMCountStructElementTypes <void*-array>
128 [ LLVMGetStructElementTypes ] keep >array
129 [ (tref>) ] map >>types ;
131 TUPLE: array < enclosing size type ;
132 : <array> ( s t -- o )
134 swap >>type swap >>size ;
136 M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
137 M: array clean* type>> clean ;
139 over LLVMGetElementType (tref>) >>type
140 swap LLVMGetArrayLength >>size ;
143 TUPLE: function < enclosing return params vararg? ;
144 : <function> ( ret params var? -- o )
146 swap >>vararg? swap >>params swap >>return ;
148 M: function (>tref)* {
150 [ params>> [ (>tref) ] map >void*-array ]
153 } cleave LLVMFunctionType ;
154 M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
156 over LLVMIsFunctionVarArg 0 = not >>vararg?
157 over LLVMGetReturnType (tref>) >>return
158 swap dup LLVMCountParamTypes <void*-array>
159 [ LLVMGetParamTypes ] keep >array
160 [ (tref>) ] map >>params ;
162 : type-kind ( LLVMTypeRef -- class )
164 { LLVMVoidTypeKind [ void ] }
165 { LLVMFloatTypeKind [ float ] }
166 { LLVMDoubleTypeKind [ double ] }
167 { LLVMX86_FP80TypeKind [ x86_fp80 ] }
168 { LLVMFP128TypeKind [ fp128 ] }
169 { LLVMPPC_FP128TypeKind [ ppc_fp128 ] }
170 { LLVMLabelTypeKind [ label ] }
171 { LLVMIntegerTypeKind [ integer new ] }
172 { LLVMFunctionTypeKind [ function new ] }
173 { LLVMStructTypeKind [ struct new ] }
174 { LLVMArrayTypeKind [ array new ] }
175 { LLVMPointerTypeKind [ pointer new ] }
176 { LLVMOpaqueTypeKind [ opaque ] }
177 { LLVMVectorTypeKind [ vector new ] }
180 TUPLE: up-ref height ;
184 types get length swap height>> - types get nth
185 cached>> [ LLVMOpaqueType ] unless* ;
187 : resolve-types ( typeref typeref -- typeref )
188 over LLVMCreateTypeHandle [ LLVMRefineType ] dip
189 [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
191 : >tref-caching ( type -- LLVMTypeRef )
192 V{ } clone types [ (>tref) ] with-variable ;
194 : >tref ( type -- LLVMTypeRef )
195 [ >tref-caching ] [ >tref-caching ] [ clean ] tri
196 2dup = [ drop ] [ resolve-types ] if ;
198 : tref> ( LLVMTypeRef -- type )
199 V{ } clone types [ (tref>) ] with-variable ;
203 "type-info" LLVMModuleCreateWithName
204 [ "t" rot LLVMAddTypeName drop ]
206 [ LLVMDisposeModule ] tri ;
212 Zero = "0" => [[ drop 0 ]]
215 Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]]
216 WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]]
217 WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]]
219 Integer = "i" Number:n => [[ n <integer> ]]
220 FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]]
221 LabelVoidMetadata = ( "label" | "void" | "metadata" | "opaque" ) => [[ "llvm.types" vocab lookup ]]
222 Primitive = LabelVoidMetadata | FloatingPoint
223 Pointer = T:t WhiteSpace "*" => [[ t <pointer> ]]
224 Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
225 StructureTypesList = "," Type:t => [[ t ]]
226 Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
227 Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
228 NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]]
229 VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
230 ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
231 ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
232 Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot <function> ]]
233 PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
234 UpReference = "\\" Number:n => [[ n <up-ref> ]]
235 Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
237 T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
239 Type = WhiteSpace T:t WhiteSpace => [[ t ]]
245 SYNTAX: TYPE: ";" parse-multiline-string parse-type suffix! ;