basis/compiler/codegen/relocation/relocation.factor

   1 ! Copyright (C) 2011 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.accessors alien.strings
   4 compiler.constants kernel make math math.bitwise namespaces
   5 sequences ;
   6 IN: compiler.codegen.relocation
   7
   8 SYMBOL: extra-offset  ! Only used by non-optimizing compiler
   9
  10 : compiled-offset ( -- n )
  11     building get length extra-offset get + ;
  12
  13 : alignment ( align -- n )
  14     [ compiled-offset dup ] dip align swap - ;
  15
  16 : (align-code) ( n -- )
  17     0 <repetition> % ;
  18
  19 : align-code ( n -- )
  20     alignment (align-code) ;
  21
  22 SYMBOL: parameter-table
  23
  24 : add-parameter ( obj -- ) parameter-table get push ;
  25
  26 ! Literal table
  27 SYMBOL: literal-table
  28
  29 : add-literal ( obj -- ) literal-table get push ;
  30
  31 SYMBOL: relocation-table
  32
  33 : push-uint ( value vector -- )
  34     ! If we ever revive PowerPC support again, this needs to be
  35     ! changed to reverse the byte order when bootstrapping from
  36     ! x86 to PowerPC or vice versa
  37     [ length ] [ B{ 0 0 0 0 } swap push-all ] [ underlying>> ] tri
  38     swap set-alien-unsigned-4 ;
  39
  40 : add-relocation-at ( class type offset -- )
  41     { 0 28 24 } bitfield relocation-table get push-uint ;
  42
  43 : add-relocation ( class type -- )
  44     compiled-offset add-relocation-at ;
  45
  46 ! Caching common symbol names reduces image size a bit
  47 MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
  48
  49 : add-dlsym-parameters ( symbol dll -- )
  50     [ cached-string>symbol add-parameter ] [ add-parameter ] bi* ;
  51
  52 : rel-dlsym ( name dll class -- )
  53     [ add-dlsym-parameters ] dip rt-dlsym add-relocation ;
  54
  55 : rel-dlsym-toc ( name dll class -- )
  56     [ add-dlsym-parameters ] dip rt-dlsym-toc add-relocation ;
  57
  58 : rel-word ( word class -- )
  59     [ add-literal ] dip rt-entry-point add-relocation ;
  60
  61 : rel-word-pic ( word class -- )
  62     [ add-literal ] dip rt-entry-point-pic add-relocation ;
  63
  64 : rel-word-pic-tail ( word class -- )
  65     [ add-literal ] dip rt-entry-point-pic-tail add-relocation ;
  66
  67 : rel-literal ( literal class -- )
  68     [ add-literal ] dip rt-literal add-relocation ;
  69
  70 : rel-untagged ( literal class -- )
  71     [ add-literal ] dip rt-untagged add-relocation ;
  72
  73 : rel-this ( class -- )
  74     rt-this add-relocation ;
  75
  76 : rel-here ( offset class -- )
  77     [ add-literal ] dip rt-here add-relocation ;
  78
  79 : rel-vm ( offset class -- )
  80     [ add-parameter ] dip rt-vm add-relocation ;
  81
  82 : rel-cards-offset ( class -- )
  83     rt-cards-offset add-relocation ;
  84
  85 : rel-decks-offset ( class -- )
  86     rt-decks-offset add-relocation ;
  87
  88 : rel-megamorphic-cache-hits ( class -- )
  89     rt-megamorphic-cache-hits add-relocation ;
  90
  91 : rel-inline-cache-miss ( class -- )
  92     rt-inline-cache-miss add-relocation ;
  93
  94 : rel-safepoint ( class -- )
  95     rt-safepoint add-relocation ;
  96
  97 : init-relocation ( -- )
  98     V{ } clone parameter-table set
  99     V{ } clone literal-table set
 100     BV{ } clone relocation-table set
 101     0 extra-offset set ;