basis/compiler/cfg/builder/alien/boxing/boxing.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types arrays assocs classes.struct
   4 combinators compiler.cfg.builder.alien.params compiler.cfg.hats
   5 compiler.cfg.instructions compiler.cfg.intrinsics.allot
   6 compiler.cfg.registers cpu.architecture fry kernel layouts
   7 locals math namespaces sequences system ;
   8 QUALIFIED-WITH: alien.c-types c
   9 IN: compiler.cfg.builder.alien.boxing
  10
  11 SYMBOL: struct-return-area
  12
  13 SYMBOLS: int-reg-reps float-reg-reps ;
  14
  15 : reg-reps ( reps -- int-reps float-reps )
  16     [ second ] reject [ [ first int-rep? ] count ] [ length over - ] bi ;
  17
  18 : record-reg-reps ( reps -- reps )
  19     dup reg-reps [ int-reg-reps +@ ] [ float-reg-reps +@ ] bi* ;
  20
  21 : unrecord-reg-reps ( reps -- reps )
  22     dup reg-reps [ neg int-reg-reps +@ ] [ neg float-reg-reps +@ ] bi* ;
  23
  24 GENERIC: flatten-c-type ( c-type -- pairs )
  25
  26 M: c-type flatten-c-type
  27     rep>> f f 3array 1array record-reg-reps ;
  28
  29 M: long-long-type flatten-c-type
  30     drop 2 [ int-rep long-long-on-stack? f 3array ] replicate record-reg-reps ;
  31
  32 HOOK: flatten-struct-type cpu ( type -- pairs )
  33 HOOK: flatten-struct-type-return cpu ( type -- pairs )
  34
  35 M: object flatten-struct-type
  36     heap-size cell align cell /i { int-rep f f } <array> record-reg-reps ;
  37
  38 M: struct-c-type flatten-c-type
  39     flatten-struct-type ;
  40
  41 M: object flatten-struct-type-return
  42     flatten-struct-type ;
  43
  44 : stack-size ( c-type -- n )
  45     base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
  46
  47 : component-offsets ( reps -- offsets )
  48     0 [ rep-size + ] accumulate nip ;
  49
  50 :: explode-struct ( src c-type -- vregs reps )
  51     c-type flatten-struct-type :> reps
  52     reps keys dup component-offsets
  53     [| rep offset | src offset rep f ^^load-memory-imm ] 2map
  54     reps ;
  55
  56 :: explode-struct-return ( src c-type -- vregs reps )
  57     c-type flatten-struct-type-return :> reps
  58     reps keys dup component-offsets
  59     [| rep offset | src offset rep f ^^load-memory-imm ] 2map
  60     reps ;
  61
  62 :: implode-struct ( src vregs reps -- )
  63     vregs reps dup component-offsets
  64     [| vreg rep offset | vreg src offset rep f ##store-memory-imm, ] 3each ;
  65
  66 GENERIC: unbox ( src c-type -- vregs reps )
  67
  68 M: c-type unbox
  69     [ rep>> ] [ unboxer>> ] bi
  70     [
  71         {
  72             { "to_float" [ drop ] }
  73             { "to_double" [ drop ] }
  74             { "to_signed_1" [ drop ] }
  75             { "to_unsigned_1" [ drop ] }
  76             { "to_signed_2" [ drop ] }
  77             { "to_unsigned_2" [ drop ] }
  78             { "to_signed_4" [ drop ] }
  79             { "to_unsigned_4" [ drop ] }
  80             { "alien_offset" [ drop ^^unbox-any-c-ptr ] }
  81             [ swap ^^unbox ]
  82         } case 1array
  83     ]
  84     [ drop f f 3array 1array ] 2bi record-reg-reps ;
  85
  86 M: long-long-type unbox
  87     [ next-vreg next-vreg 2dup ] 2dip unboxer>> ##unbox-long-long, 2array
  88     int-rep long-long-on-stack? long-long-odd-register? 3array
  89     int-rep long-long-on-stack? f 3array 2array record-reg-reps ;
  90
  91 M: struct-c-type unbox ( src c-type -- vregs reps )
  92     [ ^^unbox-any-c-ptr ] dip explode-struct ;
  93
  94 : frob-struct ( c-type -- c-type )
  95     dup value-struct? [ drop void* base-type ] unless ;
  96
  97 GENERIC: unbox-parameter ( src c-type -- vregs reps )
  98
  99 M: c-type unbox-parameter unbox ;
 100
 101 M: long-long-type unbox-parameter unbox ;
 102
 103 M: struct-c-type unbox-parameter
 104     dup value-struct? [ unbox ] [
 105         [ nip heap-size cell f ^^local-allot dup ]
 106         [ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi
 107         implode-struct
 108         1array { { int-rep f f } }
 109     ] if ;
 110
 111 : store-return ( vregs reps -- triples )
 112     [ [ dup next-return-reg 3array ] 2map ] with-return-regs ;
 113
 114 GENERIC: unbox-return ( src c-type -- vregs reps )
 115
 116 M: abstract-c-type unbox-return
 117     ! Don't care about on-stack? flag when looking at return
 118     ! values.
 119     unbox keys ;
 120
 121 M: struct-c-type unbox-return
 122     dup return-struct-in-registers?
 123     [ call-next-method ]
 124     [ [ struct-return-area get ] 2dip unbox keys implode-struct { } { } ] if ;
 125
 126 GENERIC: flatten-parameter-type ( c-type -- reps )
 127
 128 M: abstract-c-type flatten-parameter-type flatten-c-type ;
 129
 130 M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
 131
 132 GENERIC: box ( vregs reps c-type -- dst )
 133
 134 M: c-type box
 135     [ [ first ] bi@ ] [ boxer>> ] bi*
 136     {
 137         { "from_float" [ drop ] }
 138         { "from_double" [ drop ] }
 139         { "from_signed_1" [ drop c:char ^^convert-integer ] }
 140         { "from_unsigned_1" [ drop c:uchar ^^convert-integer ] }
 141         { "from_signed_2" [ drop c:short ^^convert-integer ] }
 142         { "from_unsigned_2" [ drop c:ushort ^^convert-integer ] }
 143         { "from_signed_4" [ drop c:int ^^convert-integer ] }
 144         { "from_unsigned_4" [ drop c:uint ^^convert-integer ] }
 145         { "allot_alien" [ drop ^^box-alien ] }
 146         [ swap <gc-map> ^^box ]
 147     } case ;
 148
 149 M: long-long-type box
 150     [ first2 ] [ drop ] [ boxer>> ] tri*
 151     <gc-map> ^^box-long-long ;
 152
 153 M: struct-c-type box
 154     '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
 155     implode-struct ;
 156
 157 GENERIC: box-parameter ( vregs reps c-type -- dst )
 158
 159 M: abstract-c-type box-parameter box ;
 160
 161 M: struct-c-type box-parameter
 162     dup value-struct?
 163     [ [ [ drop first ] dip explode-struct keys ] keep ] unless
 164     box ;
 165
 166 GENERIC: load-return ( c-type -- triples )
 167
 168 M: abstract-c-type load-return
 169     [
 170         flatten-c-type keys
 171         [ [ next-vreg ] dip dup next-return-reg 3array ] map
 172     ] with-return-regs ;
 173
 174 M: struct-c-type load-return
 175     dup return-struct-in-registers?
 176     [ call-next-method ] [ drop { } ] if ;
 177
 178 GENERIC: box-return ( vregs reps c-type -- dst )
 179
 180 M: abstract-c-type box-return box ;
 181
 182 M: struct-c-type box-return
 183     dup return-struct-in-registers?
 184     [ call-next-method ]
 185     [
 186         [
 187             [ [ { } assert-sequence= ] bi@ struct-return-area get ] dip
 188             explode-struct-return keys
 189         ] keep box
 190     ] if ;