basis/compiler/codegen/gc-maps/gc-maps.factor

   1 ! Copyright (C) 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs bit-arrays classes.tuple
   4 compiler.codegen.relocation cpu.architecture fry kernel layouts make math
   5 math.order namespaces sequences ;
   6 IN: compiler.codegen.gc-maps
   7
   8 SYMBOLS: return-addresses gc-maps ;
   9
  10 : gc-map-needed? ( gc-map/f -- ? )
  11     dup [ tuple-slots [ empty? ] all? not ] when ;
  12
  13 : gc-map-here ( gc-map -- )
  14     dup gc-map-needed? [
  15         gc-maps get push
  16         compiled-offset return-addresses get push
  17     ] [ drop ] if ;
  18
  19 : emit-scrub ( seqs -- n )
  20     ! seqs is a sequence of sequences of 0/1
  21     dup longest length
  22     [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
  23
  24 : integers>bits ( seq n -- bit-array )
  25     <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
  26
  27 : largest-spill-slot ( seqs -- n )
  28     [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce ;
  29
  30 : emit-gc-roots ( seqs -- n )
  31     ! seqs is a sequence of sequences of integers 0..n-1
  32     dup largest-spill-slot [ '[ _ integers>bits % ] each ] keep ;
  33
  34 : emit-uint ( n -- )
  35     building get push-uint ;
  36
  37 : emit-uints ( n -- )
  38     [ emit-uint ] each ;
  39
  40 : gc-root-offsets ( gc-map -- offsets )
  41     gc-roots>> [ gc-root-offset ] map ;
  42
  43 : emit-gc-info-bitmaps ( -- counts )
  44     [
  45         gc-maps get
  46         [ [ scrub-d>> ] map emit-scrub ]
  47         [ [ scrub-r>> ] map emit-scrub ]
  48         [ [ gc-root-offsets ] map emit-gc-roots ] tri 3array
  49     ] ?{ } make underlying>> % ;
  50
  51 : emit-base-table ( alist longest -- )
  52     -1 <array> <enum> swap assoc-union! seq>> emit-uints ;
  53
  54 : derived-root-offsets ( gc-map -- offsets )
  55     derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
  56
  57 : emit-base-tables ( -- count )
  58     gc-maps get [ derived-root-offsets ] map
  59     dup [ keys ] map largest-spill-slot
  60     [ '[ _ emit-base-table ] each ] keep ;
  61
  62 : emit-return-addresses ( -- )
  63     return-addresses get emit-uints ;
  64
  65 : serialize-gc-maps ( -- byte-array )
  66     [
  67         return-addresses get empty? [ 0 emit-uint ] [
  68             emit-gc-info-bitmaps
  69             emit-base-tables suffix
  70             emit-return-addresses
  71             emit-uints
  72             return-addresses get length emit-uint
  73         ] if
  74     ] B{ } make ;
  75
  76 : init-gc-maps ( -- )
  77     V{ } clone return-addresses set
  78     V{ } clone gc-maps set ;
  79
  80 : emit-gc-maps ( -- )
  81     ! We want to place the GC maps so that the end is aligned
  82     ! on a 16-byte boundary.
  83     serialize-gc-maps [
  84         length compiled-offset +
  85         [ data-alignment get align ] keep -
  86         (align-code)
  87     ] [ % ] bi ;