extra/llvm/types/types.factor

   1 USING: accessors arrays combinators kernel llvm.core
   2 locals math.parser math multiline
   3 namespaces parser peg.ebnf sequences
   4 sequences.deep specialized-arrays.alien strings vocabs words ;
   5
   6 IN: llvm.types
   7
   8 ! Type resolution strategy:
   9 !  pass 1:
  10 !    create the type with uprefs mapped to opaque types
  11 !    cache typerefs in enclosing types for pass 2
  12 !    if our type is concrete, then we are done
  13 !
  14 !  pass 2:
  15 !    wrap our abstract type in a type handle
  16 !    create a second type, using the cached enclosing type info
  17 !    resolve the first type to the second
  18 !
  19 GENERIC: (>tref) ( type -- LLVMTypeRef )
  20 GENERIC: ((tref>)) ( LLVMTypeRef type -- type )
  21
  22 ! default implementation for simple types
  23 M: object ((tref>)) nip ;
  24
  25 TUPLE: integer size ;
  26 C: <integer> integer
  27
  28 M: integer (>tref) size>> LLVMIntType ;
  29 M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ;
  30
  31 SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
  32
  33 M: float (>tref) drop LLVMFloatType ;
  34 M: double (>tref) drop LLVMDoubleType ;
  35 M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
  36 M: fp128 (>tref) drop LLVMFP128Type ;
  37 M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
  38
  39 SINGLETONS: opaque label void metadata ;
  40
  41 M: opaque (>tref) drop LLVMOpaqueType ;
  42 M: label (>tref) drop LLVMLabelType ;
  43 M: void (>tref) drop LLVMVoidType ;
  44 M: metadata (>tref) drop
  45     "metadata types unsupported by llvm c bindings" throw ;
  46
  47 ! enclosing types cache their llvm refs during
  48 ! the first pass, used in the second pass to
  49 ! resolve uprefs
  50 TUPLE: enclosing cached ;
  51
  52 GENERIC: clean ( type -- )
  53 GENERIC: clean* ( type -- )
  54 M: object clean drop ;
  55 M: enclosing clean f >>cached clean* ;
  56
  57 ! builds the stack of types that uprefs need to refer to
  58 SYMBOL: types
  59 :: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
  60     type types get push
  61     type quot call( type -- LLVMTypeRef )
  62     types get pop over >>cached drop ;
  63
  64 DEFER: <up-ref>
  65 :: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type )
  66     ref types get index
  67     [ types get length swap - <up-ref> ] [
  68         ref types get push
  69         ref quot call( LLVMTypeRef -- type )
  70         types get pop drop
  71     ] if* ;
  72
  73 GENERIC: (>tref)* ( type -- LLVMTypeRef )
  74 M: enclosing (>tref) [ (>tref)* ] push-type ;
  75
  76 DEFER: type-kind
  77 GENERIC: (tref>)* ( LLVMTypeRef type -- type )
  78 M: enclosing ((tref>)) [ (tref>)* ] curry push-ref ;
  79
  80 : (tref>) ( LLVMTypeRef -- type ) dup type-kind ((tref>)) ;
  81
  82 TUPLE: pointer < enclosing type ;
  83 : <pointer> ( t -- o ) pointer new swap >>type ;
  84
  85 M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
  86 M: pointer clean* type>> clean ;
  87 M: pointer (tref>)* swap LLVMGetElementType (tref>) >>type ;
  88
  89 TUPLE: vector < enclosing size type ;
  90 : <vector> ( s t -- o )
  91     vector new
  92     swap >>type swap >>size ;
  93
  94 M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
  95 M: vector clean* type>> clean ;
  96 M: vector (tref>)*
  97     over LLVMGetElementType (tref>) >>type
  98     swap LLVMGetVectorSize >>size ;
  99
 100 TUPLE: struct < enclosing types packed? ;
 101 : <struct> ( ts p? -- o )
 102     struct new
 103     swap >>packed? swap >>types ;
 104
 105 M: struct (>tref)*
 106     [ types>> [ (>tref) ] map >void*-array ]
 107     [ types>> length ]
 108     [ packed?>> 1 0 ? ] tri LLVMStructType ;
 109 M: struct clean* types>> [ clean ] each ;
 110 M: struct (tref>)*
 111     over LLVMIsPackedStruct 0 = not >>packed?
 112     swap dup LLVMCountStructElementTypes <void*-array>
 113     [ LLVMGetStructElementTypes ] keep >array
 114     [ (tref>) ] map >>types ;
 115
 116 TUPLE: array < enclosing size type ;
 117 : <array> ( s t -- o )
 118     array new
 119     swap >>type swap >>size ;
 120
 121 M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
 122 M: array clean* type>> clean ;
 123 M: array (tref>)*
 124     over LLVMGetElementType (tref>) >>type
 125     swap LLVMGetArrayLength >>size ;
 126
 127 SYMBOL: ...
 128 TUPLE: function < enclosing return params vararg? ;
 129 : <function> ( ret params var? -- o )
 130     function new
 131     swap >>vararg? swap >>params swap >>return ;
 132
 133 M: function (>tref)* {
 134     [ return>> (>tref) ]
 135     [ params>> [ (>tref) ] map >void*-array ]
 136     [ params>> length ]
 137     [ vararg?>> 1 0 ? ]
 138 } cleave LLVMFunctionType ;
 139 M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
 140 M: function (tref>)*
 141     over LLVMIsFunctionVarArg 0 = not >>vararg?
 142     over LLVMGetReturnType (tref>) >>return
 143     swap dup LLVMCountParamTypes <void*-array>
 144     [ LLVMGetParamTypes ] keep >array
 145     [ (tref>) ] map >>params ;
 146
 147 : type-kind ( LLVMTypeRef -- class )
 148     LLVMGetTypeKind {
 149         { LLVMVoidTypeKind [ void ] }
 150         { LLVMFloatTypeKind [ float ] }
 151         { LLVMDoubleTypeKind [ double ] }
 152         { LLVMX86_FP80TypeKind [ x86_fp80 ] }
 153         { LLVMFP128TypeKind [ fp128 ] }
 154         { LLVMPPC_FP128TypeKind [ ppc_fp128 ] }
 155         { LLVMLabelTypeKind [ label ] }
 156         { LLVMIntegerTypeKind [ integer new ] }
 157         { LLVMFunctionTypeKind [ function new ] }
 158         { LLVMStructTypeKind [ struct new ] }
 159         { LLVMArrayTypeKind [ array new ] }
 160         { LLVMPointerTypeKind [ pointer new ] }
 161         { LLVMOpaqueTypeKind [ opaque ] }
 162         { LLVMVectorTypeKind [ vector new ] }
 163    } case ;
 164
 165 TUPLE: up-ref height ;
 166 C: <up-ref> up-ref
 167
 168 M: up-ref (>tref)
 169     types get length swap height>> - types get nth
 170     cached>> [ LLVMOpaqueType ] unless* ;
 171
 172 : resolve-types ( typeref typeref -- typeref )
 173     over LLVMCreateTypeHandle [ LLVMRefineType ] dip
 174     [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
 175
 176 : >tref-caching ( type -- LLVMTypeRef )
 177     V{ } clone types [ (>tref) ] with-variable ;
 178
 179 : >tref ( type -- LLVMTypeRef )
 180     [ >tref-caching ] [ >tref-caching ] [ clean ] tri
 181     2dup = [ drop ] [ resolve-types ] if ;
 182
 183 : tref> ( LLVMTypeRef -- type )
 184     V{ } clone types [ (tref>) ] with-variable ;
 185
 186 : t. ( type -- )
 187     >tref
 188     "type-info" LLVMModuleCreateWithName
 189     [ "t" rot LLVMAddTypeName drop ]
 190     [ LLVMDumpModule ]
 191     [ LLVMDisposeModule ] tri ;
 192
 193 EBNF: parse-type
 194
 195 WhiteSpace = " "*
 196
 197 Zero = "0" => [[ drop 0 ]]
 198 LeadingDigit = [1-9]
 199 DecimalDigit = [0-9]
 200 Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]]
 201 WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]]
 202 WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]]
 203
 204 Integer = "i" Number:n => [[ n <integer> ]]
 205 FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]]
 206 LabelVoidMetadata = ( "label" | "void" | "metadata" | "opaque" ) => [[ "llvm.types" vocab lookup ]]
 207 Primitive = LabelVoidMetadata | FloatingPoint
 208 Pointer = T:t WhiteSpace "*" => [[ t <pointer> ]]
 209 Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
 210 StructureTypesList = "," Type:t => [[ t ]]
 211 Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
 212 Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
 213 NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]]
 214 VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
 215 ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
 216 ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
 217 Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot <function> ]]
 218 PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
 219 UpReference = "\\" Number:n => [[ n <up-ref> ]]
 220 Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
 221
 222 T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
 223
 224 Type = WhiteSpace T:t WhiteSpace => [[ t ]]
 225
 226 Program = Type
 227
 228 ;EBNF
 229
 230 SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ;