core/compiler/generator/architecture.factor

   1 IN: compiler
   2 USING: arrays generic kernel kernel-internals math memory
   3 namespaces sequences ;
   4
   5 ! Does the assembler emit bytes or cells?
   6 DEFER: code-format ( -- byte# )
   7
   8 ! A scratch register for computations
   9 TUPLE: vreg n ;
  10
  11 C: vreg ( n reg-class -- vreg )
  12     [ set-delegate ] keep [ set-vreg-n ] keep ;
  13
  14 ! Register classes
  15 TUPLE: int-regs ;
  16 TUPLE: float-regs size ;
  17
  18 : <int-vreg> ( n -- vreg ) T{ int-regs } <vreg> ;
  19 : <float-vreg> ( n -- vreg ) T{ float-regs f 8 } <vreg> ;
  20
  21 ! A pseudo-register class for parameters spilled on the stack
  22 TUPLE: stack-params ;
  23
  24 ! Return values of this class go here
  25 GENERIC: return-reg ( register-class -- reg )
  26
  27 ! Sequence of registers used for parameter passing in class
  28 GENERIC: fastcall-regs ( register-class -- regs )
  29
  30 ! Sequence mapping vreg-n to native assembler registers
  31 GENERIC: vregs ( register-class -- regs )
  32
  33 ! Map a sequence of literals to f or float
  34 DEFER: literal-template ( literals -- template )
  35
  36 ! Load a literal (immediate or indirect)
  37 G: load-literal ( obj vreg -- ) 1 standard-combination ;
  38
  39 ! Set up caller stack frame
  40 DEFER: %prologue ( n -- )
  41
  42 ! Tear down stack frame
  43 DEFER: %epilogue ( -- )
  44
  45 ! Tail call another word
  46 DEFER: %jump ( label -- )
  47
  48 ! Call another word
  49 DEFER: %call ( label -- )
  50
  51 ! Local jump for branches or tail calls in nested #label
  52 DEFER: %jump-label ( label -- )
  53
  54 ! Test if vreg is 'f' or not
  55 DEFER: %jump-t ( label vreg -- )
  56
  57 ! Jump table of addresses (one cell each) is right after this
  58 DEFER: %dispatch ( -- )
  59
  60 ! Jump table entry
  61 DEFER: %target ( label -- )
  62
  63 ! Return to caller
  64 DEFER: %return ( -- )
  65
  66 ! Change datastack height
  67 DEFER: %inc-d ( n -- )
  68
  69 ! Change callstack height
  70 DEFER: %inc-r ( n -- )
  71
  72 ! Load stack into vreg
  73 GENERIC: (%peek) ( vreg loc reg-class -- )
  74 : %peek ( vreg loc -- ) over (%peek) ;
  75
  76 ! Store vreg to stack
  77 GENERIC: (%replace) ( vreg loc reg-class -- )
  78 : %replace ( vreg loc -- ) over (%replace) ;
  79
  80 ! Move one vreg to another
  81 DEFER: %move-int>int ( dst src -- )
  82 DEFER: %move-int>float ( dst src -- )
  83
  84 : %move ( dst src -- )
  85     2dup = [
  86         2drop
  87     ] [
  88         2dup [ delegate class ] 2apply 2array {
  89             { [ dup { int-regs int-regs } = ] [ drop %move-int>int ] }
  90             { [ dup { float-regs int-regs } = ] [ drop %move-int>float ] }
  91         } cond
  92     ] if ;
  93
  94 ! FFI stuff
  95 DEFER: %unbox ( n reg-class func -- )
  96
  97 DEFER: %unbox-struct ( n size -- )
  98
  99 DEFER: %box ( n reg-class func -- )
 100
 101 DEFER: %box-struct ( n size -- )
 102
 103 GENERIC: %freg>stack ( stack reg reg-class -- )
 104
 105 GENERIC: %stack>freg ( stack reg reg-class -- )
 106
 107 DEFER: %alien-invoke ( library function -- )
 108
 109 DEFER: %cleanup ( n -- )
 110
 111 DEFER: %alien-callback ( quot -- )
 112
 113 DEFER: %callback-value ( reg-class func -- )
 114
 115 DEFER: %prepare-alien-indirect ( -- )
 116
 117 DEFER: %alien-indirect ( -- )
 118
 119 M: stack-params fastcall-regs drop 0 ;
 120
 121 GENERIC: reg-size ( register-class -- n )
 122
 123 GENERIC: inc-reg-class ( register-class -- )
 124
 125 M: int-regs reg-size drop cell ;
 126
 127 : (inc-reg-class)
 128     dup class inc
 129     macosx? [ reg-size stack-params +@ ] [ drop ] if ;
 130
 131 M: int-regs inc-reg-class
 132     (inc-reg-class) ;
 133
 134 M: float-regs reg-size float-regs-size ;
 135
 136 M: float-regs inc-reg-class
 137     dup (inc-reg-class)
 138     macosx? [ reg-size 4 / int-regs +@ ] [ drop ] if ;
 139
 140 GENERIC: v>operand ( obj -- operand )
 141 M: integer v>operand tag-bits shift ;
 142 M: vreg v>operand dup vreg-n swap vregs nth ;
 143 M: f v>operand drop object-tag ;