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