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
  21 GENERIC: llvm> ( LLVMTypeRef -- type )
  22
  23 TUPLE: integer size ;
  24 C: <integer> integer
  25
  26 M: integer (>tref) size>> LLVMIntType ;
  27
  28 SINGLETONS: float double x86_fp80 fp128 ppc_fp128 ;
  29
  30 M: float (>tref) drop LLVMFloatType ;
  31 M: double (>tref) drop LLVMDoubleType ;
  32 M: x86_fp80 (>tref) drop LLVMX86FP80Type ;
  33 M: fp128 (>tref) drop LLVMFP128Type ;
  34 M: ppc_fp128 (>tref) drop LLVMPPCFP128Type ;
  35
  36 SINGLETONS: label void metadata ;
  37
  38 M: label (>tref) drop LLVMLabelType ;
  39 M: void (>tref) drop LLVMVoidType ;
  40 M: metadata (>tref) drop
  41     "metadata types unsupported by llvm c bindings" throw ;
  42
  43 ! enclosing types cache their llvm refs during
  44 ! the first pass, used in the second pass to
  45 ! resolve uprefs
  46 TUPLE: enclosing cached ;
  47
  48 GENERIC: clean ( type -- )
  49 GENERIC: clean* ( type -- )
  50 M: object clean drop ;
  51 M: enclosing clean f >>cached clean* ;
  52
  53 ! builds the stack of types that uprefs need to refer to
  54 SYMBOL: types
  55 :: push-type ( type quot: ( type -- LLVMTypeRef ) -- LLVMTypeRef )
  56     type types get push
  57     type quot call( type -- LLVMTypeRef )
  58     types get pop over >>cached drop ;
  59
  60 GENERIC: (>tref)* ( type -- LLVMTypeRef )
  61 M: enclosing (>tref) [ (>tref)* ] push-type ;
  62
  63 TUPLE: pointer < enclosing type ;
  64 : <pointer> ( t -- o ) pointer new swap >>type ;
  65
  66 M: pointer (>tref)* type>> (>tref) 0 LLVMPointerType ;
  67 M: pointer clean* type>> clean ;
  68
  69 TUPLE: vector < enclosing size type ;
  70 : <vector> ( s t -- o )
  71     vector new
  72     swap >>type swap >>size ;
  73
  74 M: vector (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMVectorType ;
  75 M: vector clean* type>> clean ;
  76
  77 TUPLE: struct < enclosing types packed? ;
  78 : <struct> ( ts p? -- o )
  79     struct new
  80     swap >>packed? swap >>types ;
  81
  82 M: struct (>tref)*
  83     [ types>> [ (>tref) ] map >void*-array ]
  84     [ types>> length ]
  85     [ packed?>> 1 0 ? ] tri LLVMStructType ;
  86 M: struct clean* types>> [ clean ] each ;
  87
  88 TUPLE: array < enclosing size type ;
  89 : <array> ( s t -- o )
  90     array new
  91     swap >>type swap >>size ;
  92
  93 M: array (>tref)* [ type>> (>tref) ] [ size>> ] bi LLVMArrayType ;
  94 M: array clean* type>> clean ;
  95
  96 SYMBOL: ...
  97 TUPLE: function < enclosing return params vararg? ;
  98 : <function> ( ret params var? -- o )
  99     function new
 100     swap >>vararg? swap >>params swap >>return ;
 101
 102 M: function (>tref)* {
 103     [ return>> (>tref) ]
 104     [ params>> [ (>tref) ] map >void*-array ]
 105     [ params>> length ]
 106     [ vararg?>> 1 0 ? ]
 107 } cleave LLVMFunctionType ;
 108 M: function clean* [ return>> clean ] [ params>> [ clean ] each ] bi ;
 109
 110 TUPLE: up-ref height ;
 111 C: <up-ref> up-ref
 112
 113 M: up-ref (>tref)
 114     types get length swap height>> - types get nth
 115     cached>> [ LLVMOpaqueType ] unless* ;
 116
 117 : resolve-types ( typeref typeref -- typeref )
 118     over LLVMCreateTypeHandle [ LLVMRefineType ] dip
 119     [ LLVMResolveTypeHandle ] keep LLVMDisposeTypeHandle ;
 120
 121 : >tref-caching ( type -- LLVMTypeRef )
 122     V{ } clone types [ (>tref) ] with-variable ;
 123
 124 : >tref ( type -- LLVMTypeRef )
 125     [ >tref-caching ] [ >tref-caching ] [ clean ] tri
 126     2dup = [ drop ] [ resolve-types ] if ;
 127
 128 : t. ( type -- )
 129     >tref
 130     "type-info" LLVMModuleCreateWithName
 131     [ "t" rot LLVMAddTypeName drop ]
 132     [ LLVMDumpModule ]
 133     [ LLVMDisposeModule ] tri ;
 134
 135 EBNF: parse-type
 136
 137 WhiteSpace = " "*
 138
 139 Zero = "0" => [[ drop 0 ]]
 140 LeadingDigit = [1-9]
 141 DecimalDigit = [0-9]
 142 Number = LeadingDigit:d (DecimalDigit)*:ds => [[ ds d prefix string>number ]]
 143 WhiteNumberSpace = WhiteSpace Number:n WhiteSpace => [[ n ]]
 144 WhiteZeroSpace = WhiteSpace (Zero | Number):n WhiteSpace => [[ n ]]
 145
 146 Integer = "i" Number:n => [[ n <integer> ]]
 147 FloatingPoint = ( "float" | "double" | "x86_fp80" | "fp128" | "ppc_fp128" ) => [[ "llvm.types" vocab lookup ]]
 148 LabelVoidMetadata = ( "label" | "void" | "metadata" ) => [[ "llvm.types" vocab lookup ]]
 149 Primitive = LabelVoidMetadata | FloatingPoint
 150 Pointer = T:t WhiteSpace "*" => [[ t <pointer> ]]
 151 Vector = "<" WhiteNumberSpace:n "x" Type:t ">" => [[ n t <vector> ]]
 152 StructureTypesList = "," Type:t => [[ t ]]
 153 Structure = "{" Type:t (StructureTypesList)*:ts "}" => [[ ts t prefix >array f <struct> ]]
 154 Array = "[" WhiteZeroSpace:n "x" Type:t "]" => [[ n t <array> ]]
 155 NoFunctionParams = "(" WhiteSpace ")" => [[ drop { } ]]
 156 VarArgs = WhiteSpace "..." WhiteSpace => [[ drop ... ]]
 157 ParamListContinued = "," (Type | VarArgs):t => [[ t ]]
 158 ParamList = "(" Type:t (ParamListContinued*):ts ")" => [[ ts t prefix ]]
 159 Function = T:t WhiteSpace ( ParamList | NoFunctionParams ):ts => [[ ... ts member? dup [ ... ts delete ] when t ts >array rot <function> ]]
 160 PackedStructure = "<" WhiteSpace "{" Type:ty (StructureTypesList)*:ts "}" WhiteSpace ">" => [[ ts ty prefix >array t <struct> ]]
 161 UpReference = "\\" Number:n => [[ n <up-ref> ]]
 162 Name = '%' ([a-zA-Z][a-zA-Z0-9]*):id => [[ id flatten >string ]]
 163
 164 T = Pointer | Function | Primitive | Integer | Vector | Structure | PackedStructure | Array | UpReference | Name
 165
 166 Type = WhiteSpace T:t WhiteSpace => [[ t ]]
 167
 168 Program = Type
 169
 170 ;EBNF
 171
 172 SYNTAX: TYPE: ";" parse-multiline-string parse-type parsed ;