basis/cpu/x86/32/bootstrap.factor

   1 ! Copyright (C) 2007, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: bootstrap.image.private kernel kernel.private namespaces
   4 system cpu.x86.assembler cpu.x86.assembler.operands layouts
   5 vocabs parser compiler.constants sequences math math.private
   6 generic.single.private threads.private ;
   7 IN: bootstrap.x86
   8
   9 4 \ cell set
  10
  11 : stack-frame-size ( -- n ) 8 bootstrap-cells ;
  12 : shift-arg ( -- reg ) ECX ;
  13 : div-arg ( -- reg ) EAX ;
  14 : mod-arg ( -- reg ) EDX ;
  15 : temp0 ( -- reg ) EAX ;
  16 : temp1 ( -- reg ) EDX ;
  17 : temp2 ( -- reg ) ECX ;
  18 : temp3 ( -- reg ) EBX ;
  19 : stack-reg ( -- reg ) ESP ;
  20 : frame-reg ( -- reg ) EBP ;
  21 : vm-reg ( -- reg ) ECX ;
  22 : ctx-reg ( -- reg ) EBP ;
  23 : nv-regs ( -- seq ) { ESI EDI EBX } ;
  24 : nv-reg ( -- reg ) EBX ;
  25 : ds-reg ( -- reg ) ESI ;
  26 : rs-reg ( -- reg ) EDI ;
  27 : fixnum>slot@ ( -- ) temp0 2 SAR ;
  28 : rex-length ( -- n ) 0 ;
  29
  30 : jit-call ( name -- )
  31     0 CALL rc-relative jit-dlsym ;
  32
  33 [
  34     ! save stack frame size
  35     stack-frame-size PUSH
  36     ! push entry point
  37     0 PUSH rc-absolute-cell rt-this jit-rel
  38     ! alignment
  39     ESP stack-frame-size 3 bootstrap-cells - SUB
  40 ] jit-prolog jit-define
  41
  42 [
  43     temp3 0 MOV rc-absolute-cell rt-here jit-rel
  44     0 JMP rc-relative rt-entry-point-pic-tail jit-rel
  45 ] jit-word-jump jit-define
  46
  47 : jit-load-vm ( -- )
  48     vm-reg 0 MOV 0 rc-absolute-cell jit-vm ;
  49
  50 : jit-load-context ( -- )
  51     ! VM pointer must be in vm-reg already
  52     ctx-reg vm-reg vm-context-offset [+] MOV ;
  53
  54 : jit-save-context ( -- )
  55     jit-load-context
  56     EDX ESP -4 [+] LEA
  57     ctx-reg context-callstack-top-offset [+] EDX MOV
  58     ctx-reg context-datastack-offset [+] ds-reg MOV
  59     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
  60
  61 : jit-restore-context ( -- )
  62     ds-reg ctx-reg context-datastack-offset [+] MOV
  63     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
  64
  65 [
  66     jit-load-vm
  67     jit-save-context
  68     ! call the primitive
  69     ESP [] vm-reg MOV
  70     0 CALL rc-relative rt-dlsym jit-rel
  71     ! restore ds, rs registers
  72     jit-restore-context
  73 ] jit-primitive jit-define
  74
  75 : jit-jump-quot ( -- )
  76     EAX quot-entry-point-offset [+] JMP ;
  77
  78 : jit-call-quot ( -- )
  79     EAX quot-entry-point-offset [+] CALL ;
  80
  81 [
  82     jit-load-vm
  83     ESP [] vm-reg MOV
  84     "begin_callback" jit-call
  85
  86     ! load quotation - EBP is ctx-reg so it will get clobbered
  87     ! later on
  88     EAX EBP 8 [+] MOV
  89
  90     jit-load-vm
  91     jit-load-context
  92     jit-restore-context
  93
  94     ! save C callstack pointer
  95     ctx-reg context-callstack-save-offset [+] ESP MOV
  96
  97     ! load Factor callstack pointer
  98     ESP ctx-reg context-callstack-bottom-offset [+] MOV
  99     ESP 4 ADD
 100
 101     jit-call-quot
 102
 103     jit-load-vm
 104     jit-save-context
 105
 106     ! load C callstack pointer
 107     ESP ctx-reg context-callstack-save-offset [+] MOV
 108
 109     ESP [] vm-reg MOV
 110     "end_callback" jit-call
 111 ] \ c-to-factor define-sub-primitive
 112
 113 [
 114     EAX ds-reg [] MOV
 115     ds-reg bootstrap-cell SUB
 116 ]
 117 [ jit-call-quot ]
 118 [ jit-jump-quot ]
 119 \ (call) define-combinator-primitive
 120
 121 [
 122     ! Clear x87 stack, but preserve rounding mode and exception flags
 123     ESP 2 SUB
 124     ESP [] FNSTCW
 125     FNINIT
 126     ESP [] FLDCW
 127     ESP 2 ADD
 128
 129     ! Load arguments
 130     EAX ESP stack-frame-size [+] MOV
 131     EDX ESP stack-frame-size 4 + [+] MOV
 132
 133     ! Unwind stack frames
 134     ESP EDX MOV
 135
 136     ! Load ds and rs registers
 137     jit-load-vm
 138     jit-load-context
 139     jit-restore-context
 140
 141     jit-jump-quot
 142 ] \ unwind-native-frames define-sub-primitive
 143
 144 [
 145     ! Load callstack object
 146     EBX ds-reg [] MOV
 147     ds-reg bootstrap-cell SUB
 148     ! Get ctx->callstack_bottom
 149     jit-load-vm
 150     jit-load-context
 151     EAX ctx-reg context-callstack-bottom-offset [+] MOV
 152     ! Get top of callstack object -- 'src' for memcpy
 153     EBP EBX callstack-top-offset [+] LEA
 154     ! Get callstack length, in bytes --- 'len' for memcpy
 155     EDX EBX callstack-length-offset [+] MOV
 156     EDX tag-bits get SHR
 157     ! Compute new stack pointer -- 'dst' for memcpy
 158     EAX EDX SUB
 159     ! Install new stack pointer
 160     ESP EAX MOV
 161     ! Call memcpy
 162     EDX PUSH
 163     EBP PUSH
 164     EAX PUSH
 165     "factor_memcpy" jit-call
 166     ESP 12 ADD
 167     ! Return with new callstack
 168     0 RET
 169 ] \ set-callstack define-sub-primitive
 170
 171 [
 172     jit-load-vm
 173     jit-save-context
 174
 175     ! Store arguments
 176     ESP [] EAX MOV
 177     ESP 4 [+] vm-reg MOV
 178
 179     ! Call VM
 180     "lazy_jit_compile" jit-call
 181 ]
 182 [ jit-call-quot ]
 183 [ jit-jump-quot ]
 184 \ lazy-jit-compile define-combinator-primitive
 185
 186 ! Inline cache miss entry points
 187 : jit-load-return-address ( -- )
 188     EBX ESP stack-frame-size bootstrap-cell - [+] MOV ;
 189
 190 ! These are always in tail position with an existing stack
 191 ! frame, and the stack. The frame setup takes this into account.
 192 : jit-inline-cache-miss ( -- )
 193     jit-load-vm
 194     jit-save-context
 195     ESP 4 [+] vm-reg MOV
 196     ESP [] EBX MOV
 197     "inline_cache_miss" jit-call
 198     jit-restore-context ;
 199
 200 [ jit-load-return-address jit-inline-cache-miss ]
 201 [ EAX CALL ]
 202 [ EAX JMP ]
 203 \ inline-cache-miss define-combinator-primitive
 204
 205 [ jit-inline-cache-miss ]
 206 [ EAX CALL ]
 207 [ EAX JMP ]
 208 \ inline-cache-miss-tail define-combinator-primitive
 209
 210 ! Overflowing fixnum arithmetic
 211 : jit-overflow ( insn func -- )
 212     ds-reg 4 SUB
 213     jit-load-vm
 214     jit-save-context
 215     EAX ds-reg [] MOV
 216     EDX ds-reg 4 [+] MOV
 217     EBX EAX MOV
 218     [ [ EBX EDX ] dip call( dst src -- ) ] dip
 219     ds-reg [] EBX MOV
 220     [ JNO ]
 221     [
 222         ESP [] EAX MOV
 223         ESP 4 [+] EDX MOV
 224         ESP 8 [+] vm-reg MOV
 225         jit-call
 226     ]
 227     jit-conditional ;
 228
 229 [ [ ADD ] "overflow_fixnum_add" jit-overflow ] \ fixnum+ define-sub-primitive
 230
 231 [ [ SUB ] "overflow_fixnum_subtract" jit-overflow ] \ fixnum- define-sub-primitive
 232
 233 [
 234     ds-reg 4 SUB
 235     jit-load-vm
 236     jit-save-context
 237     EBX ds-reg [] MOV
 238     EAX EBX MOV
 239     EBP ds-reg 4 [+] MOV
 240     EBP tag-bits get SAR
 241     EBP IMUL
 242     ds-reg [] EAX MOV
 243     [ JNO ]
 244     [
 245         EBX tag-bits get SAR
 246         ESP [] EBX MOV
 247         ESP 4 [+] EBP MOV
 248         ESP 8 [+] vm-reg MOV
 249         "overflow_fixnum_multiply" jit-call
 250     ]
 251     jit-conditional
 252 ] \ fixnum* define-sub-primitive
 253
 254 ! Contexts
 255 : jit-switch-context ( reg -- )
 256     ! Save ds, rs registers
 257     jit-load-vm
 258     jit-save-context
 259
 260     ! Make the new context the current one
 261     ctx-reg swap MOV
 262     vm-reg vm-context-offset [+] ctx-reg MOV
 263
 264     ! Load new stack pointer
 265     ESP ctx-reg context-callstack-top-offset [+] MOV
 266
 267     ! Load new ds, rs registers
 268     jit-restore-context ;
 269
 270 : jit-set-context ( -- )
 271     ! Load context and parameter from datastack
 272     EAX ds-reg [] MOV
 273     EAX EAX alien-offset [+] MOV
 274     EBX ds-reg -4 [+] MOV
 275     ds-reg 8 SUB
 276
 277     ! Make the new context active
 278     EAX jit-switch-context
 279
 280     ! Twiddle stack for return
 281     ESP 4 ADD
 282
 283     ! Store parameter to datastack
 284     ds-reg 4 ADD
 285     ds-reg [] EBX MOV ;
 286
 287 [ jit-set-context ] \ (set-context) define-sub-primitive
 288
 289 : jit-start-context ( -- )
 290     ! Create the new context in return-reg
 291     jit-load-vm
 292     ESP [] vm-reg MOV
 293     "new_context" jit-call
 294
 295     ! Save pointer to quotation and parameter
 296     EBX ds-reg MOV
 297     ds-reg 8 SUB
 298
 299     ! Make the new context active
 300     EAX jit-switch-context
 301
 302     ! Push parameter
 303     EAX EBX -4 [+] MOV
 304     ds-reg 4 ADD
 305     ds-reg [] EAX MOV
 306
 307     ! Jump to initial quotation
 308     EAX EBX [] MOV
 309     jit-jump-quot ;
 310
 311 [ jit-start-context ] \ (start-context) define-sub-primitive
 312
 313 : jit-delete-current-context ( -- )
 314     jit-load-vm
 315     jit-load-context
 316     ESP [] vm-reg MOV
 317     ESP 4 [+] ctx-reg MOV
 318     "delete_context" jit-call ;
 319
 320 [
 321     jit-delete-current-context
 322     jit-set-context
 323 ] \ (set-context-and-delete) define-sub-primitive
 324
 325 [
 326     jit-delete-current-context
 327     jit-start-context
 328 ] \ (start-context-and-delete) define-sub-primitive
 329
 330 << "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
 331 call