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     unboxer>> int-rep ^^unbox
  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 frob-struct unbox ;
  69
  70 GENERIC: unbox-return ( src c-type -- )
  71
  72 : store-return ( vregs reps -- )
  73     [
  74         [ [ next-return-reg ] keep ##store-reg-param ] 2each
  75     ] with-return-regs ;
  76
  77 : (unbox-return) ( src c-type -- vregs reps )
  78     ! Don't care about on-stack? flag when looking at return
  79     ! values.
  80     unbox keys ;
  81
  82 M: c-type unbox-return (unbox-return) store-return ;
  83
  84 M: long-long-type unbox-return (unbox-return) store-return ;
  85
  86 M: struct-c-type unbox-return
  87     dup return-struct-in-registers?
  88     [ unbox keys store-return ]
  89     [ [ struct-return-area get ] 2dip (unbox-return) implode-struct ] if ;
  90
  91 GENERIC: flatten-parameter-type ( c-type -- reps )
  92
  93 M: c-type flatten-parameter-type flatten-c-type ;
  94
  95 M: long-long-type flatten-parameter-type flatten-c-type ;
  96
  97 M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
  98
  99 GENERIC: box ( vregs reps c-type -- dst )
 100
 101 M: c-type box
 102     [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
 103
 104 M: long-long-type box
 105     [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
 106
 107 M: struct-c-type box
 108     '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
 109     implode-struct ;
 110
 111 GENERIC: box-parameter ( vregs reps c-type -- dst )
 112
 113 M: c-type box-parameter box ;
 114
 115 M: long-long-type box-parameter box ;
 116
 117 M: struct-c-type box-parameter frob-struct box ;
 118
 119 GENERIC: box-return ( c-type -- dst )
 120
 121 : load-return ( c-type -- vregs reps )
 122     [
 123         flatten-c-type keys
 124         [ [ [ next-return-reg ] keep ^^load-reg-param ] keep ]
 125         1 2 mnmap
 126     ] with-return-regs ;
 127
 128 M: c-type box-return [ load-return ] keep box ;
 129
 130 M: long-long-type box-return [ load-return ] keep box ;
 131
 132 M: struct-c-type box-return
 133     [
 134         dup return-struct-in-registers?
 135         [ load-return ]
 136         [ [ ^^prepare-struct-caller ] dip explode-struct keys ] if
 137     ] keep box ;