basis/compiler/cfg/representations/preferred/preferred.factor

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays combinators compiler.cfg.def-use
   4 compiler.cfg.instructions compiler.units cpu.architecture
   5 generic kernel namespaces sequences sequences.generalizations
   6 sets words ;
   7 FROM: compiler.cfg.instructions.syntax => insn-def-slots
   8 insn-use-slots insn-temp-slots scalar-rep ;
   9 IN: compiler.cfg.representations.preferred
  10
  11 GENERIC: defs-vreg-reps ( insn -- reps )
  12 GENERIC: temp-vreg-reps ( insn -- reps )
  13 GENERIC: uses-vreg-reps ( insn -- reps )
  14
  15 M: insn defs-vreg-reps drop { } ;
  16 M: insn temp-vreg-reps drop { } ;
  17 M: insn uses-vreg-reps drop { } ;
  18
  19 <PRIVATE
  20
  21 : rep-getter-quot ( rep -- quot )
  22     {
  23         { f [ [ rep>> ] ] }
  24         { scalar-rep [ [ rep>> scalar-rep-of ] ] }
  25         [ [ drop ] swap suffix ]
  26     } case ;
  27
  28 : reps-getter-quot ( reps -- quot )
  29     dup [ rep>> { f scalar-rep } member-eq? not ] all? [
  30         [ rep>> ] map [ drop ] swap suffix
  31     ] [
  32         [ rep>> rep-getter-quot ] map dup length {
  33             { 0 [ drop [ drop f ] ] }
  34             { 1 [ first [ 1array ] compose ] }
  35             { 2 [ first2 '[ _ _ bi 2array ] ] }
  36             [ '[ _ cleave _ narray ] ]
  37         } case
  38     ] if ;
  39
  40 : define-vreg-reps-method ( insn slots word -- )
  41     [ [ drop ] ] dip '[
  42         [ _ create-method ]
  43         [ reps-getter-quot ]
  44         bi* define
  45     ] if-empty ;
  46
  47 : define-defs-vreg-reps-method ( insn -- )
  48     dup insn-def-slots \ defs-vreg-reps define-vreg-reps-method ;
  49
  50 : define-uses-vreg-reps-method ( insn -- )
  51     dup insn-use-slots \ uses-vreg-reps define-vreg-reps-method ;
  52
  53 : define-temp-vreg-reps-method ( insn -- )
  54     dup insn-temp-slots \ temp-vreg-reps define-vreg-reps-method ;
  55
  56 PRIVATE>
  57
  58 M: alien-call-insn defs-vreg-reps
  59     reg-outputs>> [ second ] map ;
  60
  61 M: ##callback-inputs defs-vreg-reps
  62     [ reg-outputs>> ] [ stack-outputs>> ] bi append [ second ] map ;
  63
  64 M: ##callback-outputs defs-vreg-reps drop { } ;
  65
  66 M: alien-call-insn uses-vreg-reps
  67     [ reg-inputs>> ] [ stack-inputs>> ] bi append [ second ] map ;
  68
  69 M: ##alien-indirect uses-vreg-reps
  70     call-next-method int-rep prefix ;
  71
  72 M: ##callback-inputs uses-vreg-reps
  73     drop { } ;
  74
  75 M: ##callback-outputs uses-vreg-reps
  76     reg-inputs>> [ second ] map ;
  77
  78 [
  79     insn-classes get
  80     [ special-vreg-insns diff [ define-defs-vreg-reps-method ] each ]
  81     [ special-vreg-insns diff [ define-uses-vreg-reps-method ] each ]
  82     [ [ define-temp-vreg-reps-method ] each ]
  83     tri
  84 ] with-compilation-unit
  85
  86 : each-def-rep ( insn vreg-quot: ( vreg rep -- ) -- )
  87     [ [ defs-vregs ] [ defs-vreg-reps ] bi ] dip 2each ; inline
  88
  89 : each-use-rep ( insn vreg-quot: ( vreg rep -- ) -- )
  90     [ [ uses-vregs ] [ uses-vreg-reps ] bi ] dip 2each ; inline
  91
  92 : each-temp-rep ( insn vreg-quot: ( vreg rep -- ) -- )
  93     [ [ temp-vregs ] [ temp-vreg-reps ] bi ] dip 2each ; inline
  94
  95 : each-rep ( insn vreg-quot: ( vreg rep -- ) -- )
  96     [ each-def-rep ] [ each-use-rep ] [ each-temp-rep ] 2tri ; inline