basis/compiler/codegen/labels/labels.factor

   1 ! Copyright (C) 2007, 2011 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs compiler.codegen.relocation
   4 compiler.constants kernel make math namespaces sequences ;
   5 IN: compiler.codegen.labels
   6
   7 ! Labels
   8 SYMBOL: label-table
   9
  10 TUPLE: label offset ;
  11
  12 : <label> ( -- label ) label new ;
  13 : define-label ( name -- ) <label> swap set ;
  14
  15 : resolve-label ( label/name -- )
  16     dup label? [ get ] unless
  17     compiled-offset >>offset drop ;
  18
  19 TUPLE: label-fixup-state { label label } { class integer } { offset integer } ;
  20
  21 : label-fixup ( label class -- )
  22     compiled-offset \ label-fixup-state boa label-table get push ;
  23
  24 : compute-target ( label-fixup -- offset )
  25     label>> offset>> [ "Unresolved label" throw ] unless* ;
  26
  27 : compute-relative-label ( label-fixup -- label )
  28     [ class>> ] [ offset>> ] [ compute-target ] tri 3array ;
  29
  30 : compute-absolute-label ( label-fixup -- )
  31     [ compute-target neg add-literal ]
  32     [ [ class>> rt-here ] [ offset>> ] bi add-relocation-at ] bi ;
  33
  34 : compute-labels ( label-fixups -- labels' )
  35     [ class>> rc-absolute? ] partition
  36     [ [ compute-absolute-label ] each ]
  37     [ [ compute-relative-label ] map concat ]
  38     bi* ;
  39
  40 SYMBOL: binary-literal-table
  41
  42 : add-binary-literal ( obj -- label )
  43     <label> [ 2array binary-literal-table get push ] keep ;
  44
  45 : rel-binary-literal ( literal class -- )
  46     [ add-binary-literal ] dip label-fixup ;
  47
  48 : emit-data ( obj label -- )
  49     over length align-code resolve-label % ;
  50
  51 : emit-binary-literals ( -- )
  52     binary-literal-table get [ emit-data ] assoc-each ;