extra/tools/image-analyzer/ref-fixer/ref-fixer.factor

   1 USING: accessors arrays combinators fry kernel layouts math
   2 math.bitwise sequences ;
   3 IN: tools.image-analyzer.ref-fixer
   4 QUALIFIED-WITH: tools.image-analyzer.vm vm
   5
   6 : update-ref ( val rel-base -- val' )
   7     [ 15 unmask ] dip - ;
   8
   9 : update-data-ref ( val rel-base -- val' )
  10     over 1 = [ 2drop 1 ] [ update-ref ] if ;
  11
  12 : update-ep-ref ( val rel-base -- val' )
  13     update-ref 4 cell * - ;
  14
  15
  16 GENERIC# fix-data-reference 1 ( struct rel-base -- )
  17
  18 M: vm:word fix-data-reference ( word rel-base -- )
  19     '[ _ update-data-ref ]
  20     {
  21         [ change-name drop ]
  22         [ change-vocabulary drop ]
  23         [ change-def drop ]
  24         [ change-props drop ]
  25     } 2cleave ;
  26
  27 M: vm:code-block fix-data-reference ( quotation rel-base -- )
  28     '[ _ update-data-ref ]
  29     [ change-owner drop ]
  30     [ change-relocation drop ]
  31     [ change-parameters drop ] 2tri ;
  32
  33 M: object fix-data-reference ( object rel-base -- )
  34     2drop ;
  35
  36 : fix-data-references ( heap-nodes rel-base -- )
  37     '[ object>> _ fix-data-reference ] each ;
  38
  39 GENERIC# fix-code-reference 1 ( struct rel-base -- )
  40
  41 M: vm:word fix-code-reference ( word rel-base -- )
  42     '[ _ update-ep-ref ] change-entry_point drop ;
  43
  44 M: vm:quotation fix-code-reference ( quotation rel-base -- )
  45     '[ _ update-ep-ref ] change-entry_point drop ;
  46
  47 M: object fix-code-reference ( object rel-base -- )
  48     2drop ;
  49
  50 CONSTANT: code-heap-shift 65536
  51
  52 : shift-code-addresses ( heap-nodes -- )
  53     [ dup object>> vm:code-block? [
  54         [ code-heap-shift + ] change-address ] when drop
  55     ] each ;
  56
  57 : shift-code-heap ( heap-nodes header -- )
  58     [ shift-code-addresses ] [
  59         [ code-heap-shift - ] change-code-relocation-base drop
  60     ] bi* ;
  61
  62 : fix-code-references ( heap-nodes rel-base -- )
  63     '[ object>> _ fix-code-reference ] each ;
  64
  65 : fix-references ( heap-nodes header -- )
  66     2dup shift-code-heap
  67     [ data-relocation-base>> fix-data-references ]
  68     [ code-relocation-base>> fix-code-references ] 2bi ;