basis/compiler/cfg/value-numbering/expressions/expressions.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays classes.algebra combinators
   4 compiler.cfg.instructions compiler.cfg.instructions.syntax
   5 compiler.cfg.value-numbering.graph generic.parser kernel make
   6 math namespaces quotations sequences sequences.private sets
   7 slots words ;
   8 IN: compiler.cfg.value-numbering.expressions
   9
  10 <<
  11
  12 GENERIC: >expr ( insn -- expr )
  13
  14 : input-values ( slot-specs -- slot-specs' )
  15     [ type>> { use literal } member-eq? ] filter ;
  16
  17 : slot->expr-quot ( slot-spec -- quot )
  18     [ name>> reader-word 1quotation ]
  19     [
  20         type>> {
  21             { use [ [ vreg>vn ] ] }
  22             { literal [ [ ] ] }
  23         } case
  24     ] bi append ;
  25
  26 : narray-quot ( length -- quot )
  27     [
  28         [ , [ f <array> ] % ]
  29         [
  30             dup <iota> [
  31                 - 1 - , [ swap [ set-array-nth ] keep ] %
  32             ] with each
  33         ] bi
  34     ] [ ] make ;
  35
  36 : >expr-quot ( insn slot-specs -- quot )
  37     [
  38         [ literalize , \ swap , ]
  39         [
  40             [ [ slot->expr-quot ] map cleave>quot % ]
  41             [ length 1 + narray-quot % ]
  42             bi
  43         ] bi*
  44     ] [ ] make ;
  45
  46 : define->expr-method ( insn slot-specs -- )
  47     [ drop \ >expr create-method-in ] [ >expr-quot ] 2bi define ;
  48
  49 insn-classes get
  50 [ foldable-insn class<= ] filter
  51 { ##copy ##load-integer ##load-reference } diff
  52 [
  53     dup "insn-slots" word-prop input-values
  54     define->expr-method
  55 ] each
  56
  57 >>
  58
  59 TUPLE: integer-expr value ;
  60
  61 C: <integer-expr> integer-expr
  62
  63 TUPLE: reference-expr value ;
  64
  65 C: <reference-expr> reference-expr
  66
  67 M: reference-expr equal?
  68     over reference-expr? [
  69         [ value>> ] bi@
  70         2dup [ float? ] both?
  71         [ fp-bitwise= ] [ eq? ] if
  72     ] [ 2drop f ] if ;
  73
  74 M: reference-expr hashcode*
  75     nip value>> dup float? [ double>bits ] [ identity-hashcode ] if ;
  76
  77 M: insn >expr drop input-expr-counter counter neg ;
  78
  79 M: ##copy >expr "Fail" throw ;
  80
  81 M: ##load-integer >expr val>> <integer-expr> ;
  82
  83 M: ##load-reference >expr obj>> <reference-expr> ;