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 : integers>bits ( seq n -- bit-array )
  20     <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
  21
  22 : largest-spill-slot ( seqs -- n )
  23     concat [ 0 ] [ supremum 1 + ] if-empty ;
  24
  25 : emit-gc-roots ( seqs -- n )
  26     ! seqs is a sequence of sequences of integers 0..n-1
  27     dup largest-spill-slot [ '[ _ integers>bits % ] each ] keep ;
  28
  29 : emit-uint ( n -- )
  30     building get push-uint ;
  31
  32 : emit-uints ( n -- )
  33     [ emit-uint ] each ;
  34
  35 : gc-root-offsets ( gc-map -- offsets )
  36     gc-roots>> [ gc-root-offset ] map ;
  37
  38 : emit-gc-info-bitmap ( gc-maps -- spill-count )
  39     [ gc-root-offsets ] map
  40     [ emit-gc-roots ] ?{ } make underlying>> % ;
  41
  42 : emit-base-table ( alist longest -- )
  43     -1 <array> <enumerated> swap assoc-union! seq>> emit-uints ;
  44
  45 : derived-root-offsets ( gc-map -- offsets )
  46     derived-roots>> [ [ gc-root-offset ] bi@ ] assoc-map ;
  47
  48 : emit-base-tables ( gc-maps -- count )
  49     [ derived-root-offsets ] map
  50     dup [ keys ] map largest-spill-slot
  51     [ '[ _ emit-base-table ] each ] keep ;
  52
  53 : serialize-gc-maps ( -- byte-array )
  54     [
  55         return-addresses get empty? [ { } ] [
  56             gc-maps get [ emit-gc-info-bitmap ] [ emit-base-tables ] bi 2array
  57         ] if
  58         return-addresses get emit-uints
  59         emit-uints
  60         return-addresses get length emit-uint
  61     ] B{ } make ;
  62
  63 : emit-gc-maps ( -- )
  64     serialize-gc-maps [
  65         length compiled-offset +
  66         [ data-alignment get align ] keep -
  67         (align-code)
  68     ] [ % ] bi ;