extra/llvm/types/types.factor

   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*
   7 IN: llvm.types
   8
   9 ! Type resolution strategy:
  10 !  pass 1:
  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
  14 !
  15 !  pass 2:
  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
  19 !
  20 GENERIC: (>tref) ( type -- LLVMTypeRef )
  21 GENERIC: ((tref>)) ( LLVMTypeRef type -- type )
  22 GENERIC: c-type ( type -- str )
  23
  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 ;
  29
  30 TUPLE: integer size ;
  31 C: <integer> integer
  32
  33 M: integer (>tref) size>> LLVMIntType ;
  34 M: integer ((tref>)) swap LLVMGetIntTypeWidth >>size ;
  35 M: integer c-type size>> {
  36     { 64 [ "longlong" ] }
  37     { 32 [ "int" ] }
  38     { 16 [ "short" ] }
  39     { 8  [ "char" ] }
  40     [ unsupported-type ]
  41 } case ;
  42
  43 SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
  44
  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 ;
  51
  52 SINGLETONS: opaque label void metadata ;
  53
  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 ;
  60
  61 ! enclosing types cache their llvm refs during
  62 ! the first pass, used in the second pass to
  63 ! resolve uprefs
  64 TUPLE: enclosing cached ;
  65
  66 GENERIC: clean ( type -- )
  67 GENERIC: clean* ( type -- )
  68 M: object clean drop ;
  69 M: enclosing clean f >>cached clean* ;
  70
  71 ! builds the stack of types that uprefs need to refer to
  72 SYMBOL: types
  73 :: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
  74     type types get push
  75     type quot call( type -- LLVMTypeRef )
  76     types get pop over >>cached drop ;
  77
  78 DEFER: <up-ref>
  79 :: push-ref ( ref quot: ( LLVMTypeRef -- type ) -- type )
  80     ref types get index
  81     [ types get length swap - <up-ref> ] [
  82         ref types get push
  83         ref quot call( LLVMTypeRef -- type )
  84         types get pop drop
  85     ] if* ;
  86
  87 GENERIC: (>tref)* ( type -- LLVMTypeRef )
  88 M: enclosing (>tref) [ (>tref)* ] push-type ;
  89
  90 DEFER: type-kind
  91 GENERIC: (tref>)* ( LLVMTypeRef type -- type )
  92 M: enclosing ((tref>)) [ (tref>)* ] curry push-ref ;
  93
  94 : (tref>) ( LLVMTypeRef -- type ) dup type-kind ((tref>)) ;
  95
  96 TUPLE: pointer < enclosing type ;
  97 : <pointer> ( t -- o ) pointer new swap >>type ;
  98
  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*" ? ;
 103
 104 TUPLE: vector < enclosing size type ;
 105 : <vector> ( s t -- o )
 106     vector new
 107     swap >>type swap >>size ;
 108
 109 M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
 110 M: vector clean* type>> clean ;
 111 M: vector (tref>)*
 112     over LLVMGetElementType (tref>) >>type
 113     swap LLVMGetVectorSize >>size ;
 114
 115 TUPLE: struct < enclosing types packed? ;
 116 : <struct> ( ts p? -- o )
 117     struct new
 118     swap >>packed? swap >>types ;
 119
 120 M: struct (>tref)*
 121     [ types>> [ (>tref) ] map >void*-array ]
 122     [ types>> length ]
 123     [ packed?>> 1 0 ? ] tri LLVMStructType ;
 124 M: struct clean* types>> [ clean ] each ;
 125 M: struct (tref>)*
 126     over LLVMIsPackedStruct 0 = not >>packed?
 127     swap dup LLVMCountStructElementTypes <void*-array>
 128     [ LLVMGetStructElementTypes ] keep >array
 129     [ (tref>) ] map >>types ;
 130
 131 TUPLE: array < enclosing size type ;
 132 : <array> ( s t -- o )
 133     array new
 134     swap >>type swap >>size ;
 135
 136 M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
 137 M: array clean* type>> clean ;
 138 M: array (tref>)*
 139     over LLVMGetElementType (tref>) >>type
 140     swap LLVMGetArrayLength >>size ;
 141
 142 SYMBOL: ...
 143 TUPLE: function < enclosing return params vararg? ;
 144 : <function> ( ret params var? -- o )
 145     function new
 146     swap >>vararg? swap >>params swap >>return ;
 147
 148 M: function (>tref)* {
 149     [ return>> (>tref) ]
 150     [ params>> [ (>tref) ] map >void*-array ]
 151     [ params>> length ]
 152     [ vararg?>> 1 0 ? ]
 153 } cleave LLVMFunctionType ;
 154 M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
 155 M: function (tref>)*
 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 ;
 161
 162 : type-kind ( LLVMTypeRef -- class )
 163     LLVMGetTypeKind {
 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 ] }
 178    } case ;
 179
 180 TUPLE: up-ref height ;
 181 C: <up-ref> up-ref
 182
 183 M: up-ref (>tref)
 184     types get length swap height>> - types get nth
 185     cached>> [ LLVMOpaqueType ] unless* ;
 186
 187 : resolve-types ( typeref typeref -- typeref )
 188     over LLVMCreateTypeHandle [ LLVMRefineType ] dip
 189     [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
 190
 191 : >tref-caching ( type -- LLVMTypeRef )
 192     V{ } clone types [ (>tref) ] with-variable ;
 193
 194 : >tref ( type -- LLVMTypeRef )
 195     [ >tref-caching ] [ >tref-caching ] [ clean ] tri
 196     2dup = [ drop ] [ resolve-types ] if ;
 197
 198 : tref> ( LLVMTypeRef -- type )
 199     V{ } clone types [ (tref>) ] with-variable ;
 200
 201 : t. ( type -- )
 202     >tref
 203     "type-info" LLVMModuleCreateWithName
 204     [ "t" rot LLVMAddTypeName drop ]
 205     [ LLVMDumpModule ]
 206     [ LLVMDisposeModule ] tri ;
 207
 208 EBNF: parse-type
 209
 210 WhiteSpace = " "*
 211
 212 Zero = "0" => [[ drop 0 ]]
 213 LeadingDigit = [1-9]
 214 DecimalDigit = [0-9]
 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 ]]
 218
 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 ]]
 236
 237 T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
 238
 239 Type = WhiteSpace T:t WhiteSpace => [[ t ]]
 240
 241 Program = Type
 242
 243 ;EBNF
 244
 245 SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ;