unmaintained/llvm/types/types.factor

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