unfinished/compiler/vops.bluesky/builder/builder.factor

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: parser kernel namespaces words layouts sequences classes
   4 classes.algebra accessors math arrays byte-arrays
   5 inference.dataflow optimizer.allot compiler.cfg compiler.vops ;
   6 IN: compiler.vops.builder
   7
   8 << : TEMP: CREATE dup [ get ] curry define-inline ; parsing >>
   9
  10 ! Temps   Inputs    Outputs
  11 TEMP: $1  TEMP: #1  TEMP: ^1
  12 TEMP: $2  TEMP: #2  TEMP: ^2
  13 TEMP: $3  TEMP: #3  TEMP: ^3
  14 TEMP: $4  TEMP: #4  TEMP: ^4
  15 TEMP: $5  TEMP: #5  TEMP: ^5
  16
  17 GENERIC: emit-literal ( vreg object -- )
  18
  19 M: fixnum emit-literal ( vreg object -- )
  20     tag-bits get shift %iconst emit ;
  21
  22 M: f emit-literal
  23     class tag-number %iconst emit ;
  24
  25 M: object emit-literal ( vreg object -- )
  26     next-vreg [ %literal-table emit ] keep
  27     swap %literal emit ;
  28
  29 : temps ( seq -- ) [ next-vreg swap set ] each ;
  30
  31 : init-intrinsic ( -- )
  32     { $1 $2 $3 $4 ^1 ^2 ^3 ^4 } temps ;
  33
  34 : load-iconst ( value -- vreg )
  35     [ next-vreg dup ] dip %iconst emit ;
  36
  37 : load-tag-mask ( -- vreg )
  38     tag-mask get load-iconst ;
  39
  40 : load-tag-bits ( -- vreg )
  41     tag-bits get load-iconst ;
  42
  43 : emit-tag-fixnum ( out in -- )
  44     load-tag-bits %shl emit ;
  45
  46 : emit-untag-fixnum ( out in -- )
  47     load-tag-bits %sar emit ;
  48
  49 : emit-untag ( out in -- )
  50     next-vreg dup tag-mask get bitnot %iconst emit
  51     %and emit ;
  52
  53 : emit-tag ( -- )
  54     $1 #1 load-tag-mask %and emit
  55     ^1 $1 emit-tag-fixnum ;
  56
  57 : emit-slot ( node -- )
  58     [ ^1 #1 #2 ] dip dup in-d>> first node-class class-tag %%slot emit ;
  59
  60 UNION: immediate fixnum POSTPONE: f ;
  61
  62 : emit-write-barrier ( node -- )
  63     dup in-d>> first node-class immediate class< [ #2 %write-barrier emit ] unless ;
  64
  65 : emit-set-slot ( node -- )
  66     [ emit-write-barrier ]
  67     [ [ #1 #2 #3 ] dip dup in-d>> second node-class class-tag %%set-slot emit ]
  68     bi ;
  69
  70 : emit-fixnum-bitnot ( -- )
  71     $1 #1 %not emit
  72     ^1 $1 load-tag-mask %xor emit ;
  73
  74 : emit-fixnum+fast ( -- )
  75     ^1 #1 #2 %iadd emit ;
  76
  77 : emit-fixnum-fast ( -- )
  78     ^1 #1 #2 %isub emit ;
  79
  80 : emit-fixnum-bitand ( -- )
  81     ^1 #1 #2 %and emit ;
  82
  83 : emit-fixnum-bitor ( -- )
  84     ^1 #1 #2 %or emit ;
  85
  86 : emit-fixnum-bitxor ( -- )
  87     ^1 #1 #2 %xor emit ;
  88
  89 : emit-fixnum*fast ( -- )
  90     $1 #1 emit-untag-fixnum
  91     ^1 $1 #2 %imul emit ;
  92
  93 : emit-fixnum-shift-left-fast ( n -- )
  94     [ $1 ] dip %iconst emit
  95     ^1 #1 $1 %shl emit ;
  96
  97 : emit-fixnum-shift-right-fast ( n -- )
  98     [ $1 ] dip %iconst emit
  99     $2 #1 $1 %sar emit
 100     ^1 $2 emit-untag ;
 101
 102 : emit-fixnum-shift-fast ( n -- )
 103     dup 0 >=
 104     [ emit-fixnum-shift-left-fast ]
 105     [ neg emit-fixnum-shift-right-fast ] if ;
 106
 107 : emit-fixnum-compare ( cc -- )
 108     $1 #1 #2 %icmp emit
 109     [ ^1 $1 ] dip %%iboolean emit ;
 110
 111 : emit-fixnum<= ( -- )
 112     cc<= emit-fixnum-compare ;
 113
 114 : emit-fixnum>= ( -- )
 115     cc>= emit-fixnum-compare ;
 116
 117 : emit-fixnum< ( -- )
 118     cc< emit-fixnum-compare ;
 119
 120 : emit-fixnum> ( -- )
 121     cc> emit-fixnum-compare ;
 122
 123 : emit-eq? ( -- )
 124     cc= emit-fixnum-compare ;
 125
 126 : emit-unbox-float ( out in -- )
 127     %%unbox-float emit ;
 128
 129 : emit-box-float ( out in -- )
 130     %%box-float emit ;
 131
 132 : emit-unbox-floats ( -- )
 133     $1 #1 emit-unbox-float
 134     $2 #2 emit-unbox-float ;
 135
 136 : emit-float+ ( -- )
 137     emit-unbox-floats
 138     $3 $1 $2 %fadd emit
 139     ^1 $3 emit-box-float ;
 140
 141 : emit-float- ( -- )
 142     emit-unbox-floats
 143     $3 $1 $2 %fsub emit
 144     ^1 $3 emit-box-float ;
 145
 146 : emit-float* ( -- )
 147     emit-unbox-floats
 148     $3 $1 $2 %fmul emit
 149     ^1 $3 emit-box-float ;
 150
 151 : emit-float/f ( -- )
 152     emit-unbox-floats
 153     $3 $1 $2 %fdiv emit
 154     ^1 $3 emit-box-float ;
 155
 156 : emit-float-compare ( cc -- )
 157     emit-unbox-floats
 158     $3 $1 $2 %fcmp emit
 159     [ ^1 $3 ] dip %%fboolean emit ;
 160
 161 : emit-float<= ( -- )
 162     cc<= emit-float-compare ;
 163
 164 : emit-float>= ( -- )
 165     cc>= emit-float-compare ;
 166
 167 : emit-float< ( -- )
 168     cc< emit-float-compare ;
 169
 170 : emit-float> ( -- )
 171     cc> emit-float-compare ;
 172
 173 : emit-float= ( -- )
 174     cc= emit-float-compare ;
 175
 176 : emit-allot ( vreg size class -- )
 177     [ tag-number ] [ type-number ] bi %%allot emit ;
 178
 179 : emit-(tuple) ( layout -- )
 180     [ [ ^1 ] dip size>> 2 + tuple emit-allot ]
 181     [ [ $1 ] dip emit-literal ] bi
 182     $2 1 emit-literal
 183     $1 ^1 $2 tuple tag-number %%set-slot emit ;
 184
 185 : emit-(array) ( n -- )
 186     [ [ ^1 ] dip 2 + array emit-allot ]
 187     [ [ $1 ] dip emit-literal ] bi
 188     $2 1 emit-literal
 189     $1 ^1 $2 array tag-number %%set-slot emit ;
 190
 191 : emit-(byte-array) ( n -- )
 192     [ [ ^1 ] dip bytes>cells 2 + byte-array emit-allot ]
 193     [ [ $1 ] dip emit-literal ] bi
 194     $2 1 emit-literal
 195     $1 ^1 $2 byte-array tag-number %%set-slot emit ;
 196
 197 ! fixnum>bignum
 198 ! bignum>fixnum
 199 ! fixnum+
 200 ! fixnum-
 201 ! getenv, setenv
 202 ! alien accessors