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 fry
   4 kernel layouts locals math namespaces sequences
   5 sequences.generalizations system
   6 compiler.cfg.builder.alien.params compiler.cfg.hats
   7 compiler.cfg.instructions cpu.architecture ;
   8 IN: compiler.cfg.builder.alien.boxing
   9
  10 SYMBOL: struct-return-area
  11
  12 ! pairs have shape { rep on-stack? }
  13 GENERIC: flatten-c-type ( c-type -- pairs )
  14
  15 M: c-type flatten-c-type
  16     rep>> f 2array 1array ;
  17
  18 M: long-long-type flatten-c-type
  19     drop 2 [ int-rep long-long-on-stack? 2array ] replicate ;
  20
  21 HOOK: flatten-struct-type cpu ( type -- pairs )
  22
  23 M: object flatten-struct-type
  24     heap-size cell align cell /i { int-rep f } <repetition> ;
  25
  26 M: struct-c-type flatten-c-type
  27     flatten-struct-type ;
  28
  29 : stack-size ( c-type -- n )
  30     base-type flatten-c-type keys 0 [ rep-size + ] reduce ;
  31
  32 : component-offsets ( reps -- offsets )
  33     0 [ rep-size + ] accumulate nip ;
  34
  35 :: explode-struct ( src c-type -- vregs reps )
  36     c-type flatten-struct-type :> reps
  37     reps keys dup component-offsets
  38     [| rep offset | src offset rep f ^^load-memory-imm ] 2map
  39     reps ;
  40
  41 :: implode-struct ( src vregs reps -- )
  42     vregs reps dup component-offsets
  43     [| vreg rep offset | vreg src offset rep f ##store-memory-imm ] 3each ;
  44
  45 GENERIC: unbox ( src c-type -- vregs reps )
  46
  47 M: c-type unbox
  48     [ unboxer>> ] [ rep>> ] bi
  49     [ ^^unbox 1array ] [ nip f 2array 1array ] 2bi ;
  50
  51 M: long-long-type unbox
  52     [ 8 cell f ^^local-allot ] dip '[ _ unboxer>> ##unbox-long-long ] keep
  53     0 cell [ int-rep f ^^load-memory-imm ] bi-curry@ bi 2array
  54     int-rep long-long-on-stack? 2array dup 2array ;
  55
  56 M: struct-c-type unbox ( src c-type -- vregs )
  57     [ ^^unbox-any-c-ptr ] dip explode-struct ;
  58
  59 : frob-struct ( c-type -- c-type )
  60     dup value-struct? [ drop void* base-type ] unless ;
  61
  62 GENERIC: unbox-parameter ( src c-type -- vregs reps )
  63
  64 M: c-type unbox-parameter unbox ;
  65
  66 M: long-long-type unbox-parameter unbox ;
  67
  68 M: struct-c-type unbox-parameter
  69     dup value-struct? [ unbox ] [
  70         [ nip heap-size cell f ^^local-allot dup ]
  71         [ [ ^^unbox-any-c-ptr ] dip explode-struct keys ] 2bi
  72         implode-struct
  73         1array { { int-rep f } }
  74     ] if ;
  75
  76 GENERIC: unbox-return ( src c-type -- )
  77
  78 : store-return ( vregs reps -- )
  79     [
  80         [ [ next-return-reg ] keep ##store-reg-param ] 2each
  81     ] with-return-regs ;
  82
  83 : (unbox-return) ( src c-type -- vregs reps )
  84     ! Don't care about on-stack? flag when looking at return
  85     ! values.
  86     unbox keys ;
  87
  88 M: c-type unbox-return (unbox-return) store-return ;
  89
  90 M: long-long-type unbox-return (unbox-return) store-return ;
  91
  92 M: struct-c-type unbox-return
  93     dup return-struct-in-registers?
  94     [ (unbox-return) store-return ]
  95     [ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
  96
  97 GENERIC: flatten-parameter-type ( c-type -- reps )
  98
  99 M: c-type flatten-parameter-type flatten-c-type ;
 100
 101 M: long-long-type flatten-parameter-type flatten-c-type ;
 102
 103 M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
 104
 105 GENERIC: box ( vregs reps c-type -- dst )
 106
 107 M: c-type box
 108     [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
 109
 110 M: long-long-type box
 111     [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
 112
 113 M: struct-c-type box
 114     '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
 115     implode-struct ;
 116
 117 GENERIC: box-parameter ( vregs reps c-type -- dst )
 118
 119 M: c-type box-parameter box ;
 120
 121 M: long-long-type box-parameter box ;
 122
 123 M: struct-c-type box-parameter
 124     dup value-struct?
 125     [ [ [ drop first ] dip explode-struct keys ] keep ] unless
 126     box ;
 127
 128 GENERIC: box-return ( c-type -- dst )
 129
 130 : load-return ( c-type -- vregs reps )
 131     [
 132         flatten-c-type keys
 133         [ [ [ next-return-reg ] keep ^^load-reg-param ] map ] keep
 134     ] with-return-regs ;
 135
 136 M: c-type box-return [ load-return ] keep box ;
 137
 138 M: long-long-type box-return [ load-return ] keep box ;
 139
 140 M: struct-c-type box-return
 141     [
 142         dup return-struct-in-registers?
 143         [ load-return ]
 144         [ [ struct-return-area get ] dip explode-struct keys ] if
 145     ] keep box ;