Mapping expressions to bytecodes

The idea is to get a postfix, executable representation of function bodies, like expps but more compact. As with expuniq, we try to ensure two representations of the same function map to the same string. 
<bytecode.spec>=
fields of op (8)
  op3 0:2 lit5 3:7
  op4 3   lit4 4:7
  op6 4:5 lit2 6:7
  op7 6   lit1 7
  op8 7

fields of lit (8) lit8 0:7

<patterns>
<constructors>
constructors
  <synthetics>


<patterns>= (<-U) [D->]
# operators for 0..31
patterns 
  u5 is any of [ narrows_lit narrowu_lit loslice ], which is op3 = [0 1 2]

<synthetics>= (<-U) [D->]
  narrows n!
     when {n != 0} is narrows_lit & lit5 = n
     otherwise is sint(n); narrows
  halt  is narrows_lit & lit5 = 0
  narrowu n!
     when {n != 0}   is narrowu_lit & lit5 = n
     otherwise is sint(n); narrowu
  unsat is narrowu_lit & lit5 = 0
  bitslice lo! hi! 
     when {lo = 0, lit5 = hi}  is  loslice & lit5
     when {}           is sint(lo); sint(hi); bitslice  # lo <= hi fails!

<patterns>+= (<-U) [<-D->]
# operators for -8..7  --- can have at most 13
patterns
  s4 is any of [ intlit addlit emitlocplus bitshiftlit ], 
  which is op3 = [3 4] & op4 = [0 1] 

<synthetics>+= (<-U) [<-D->]
addlit n!  when {n != 0, lit4! = n}   is addlit & lit4
           otherwise is sint(n); add
cl_loc_force  is addlit & lit4 = 0
#  emitlocplus n   when {lit4! = n} is emitlocplus & lit4
#                  otherwise is cl_loc; force; sint(n); add; emit_at
bitshift n!  when {lit4! = n} is bitshiftlit & lit4
               otherwise is sint(n); bitshift

<patterns>+= (<-U) [<-D->]
# operators for 1 2 4 8
patterns emit_at_loc is op3 = 5 & op4 = 0 & op6 = 0

<synthetics>+= (<-U) [<-D->]
emit_at_loc n
  when {n = 1} is emit_at_loc & lit2 = 0
  when {n = 2} is emit_at_loc & lit2 = 1
  when {n = 4} is emit_at_loc & lit2 = 2
  when {n = 8} is emit_at_loc & lit2 = 3
  otherwise    is cl_loc; force; sint(n); emit_at

<patterns>+= (<-U) [<-D->]
# operators for 1..2
patterns lit1.2 is any of [ cla_force_lit clv_lit clv_orb_lit ], 
which is op3 = 5 & op4 = 0 & op6 = [1 2 3] & op7 = 0

<synthetics>+= (<-U) [<-D]
cla n          is sint(n); cla
cla_force n    when {} is  cla_force_lit & lit1 = n-1
               otherwise is sint(n); cla; force
clv       n    when { n <= 2 } is  clv_lit & lit1 = n-1  # condition shouldn't be needed
               otherwise is sint(n); clv
clv_orb     n  when {} is  clv_orb_lit & lit1 = n-1
               otherwise is sint(n); clv; orb

<patterns>+= (<-U) [<-D]
# raw operations
patterns
  [ 
    sint8 sint16 sint32 
  ] is op3 = 5 & op4 = 0 & op6 = [1 2 3] & op7 = 1
  [ mark array set procmark proc stringlit null uint64
  ] is op3 = 5 & op4 = 1 & op6 = [0 1 2 3] & op7 = [0 1]
  [
    bitslice bitshift narrowu narrows widen fitsu fitss failmsg 
    lt le gt ge ne eq false true
    orb and not add sub mul idiv mod
    cl_loc cla clv force known emit_at if_guard neg
  ] is op3 = [6 7] & op4 = [0 1] & op6 = [0 1 2 3] & op7 = [0 1]

patterns
  nullary is mark | array | set | procmark | proc | stringlit | null 
           | lt | le | gt | ge | ne | eq | false | true
           | orb | and | not | add | sub | mul | idiv | mod
           | cl_loc | force | known | if_guard | neg | failmsg
  unary is emit_at | widen | fitsu | fitss

<constructors>= (<-U)
constructors
  nullary
  sint n!
     when {lit4! = n} is intlit & lit4
     when {lit8! = n} is sint8;  lit8
     when {lit8! = n@[8:31]!}  is sint16; lit8 = n@[0:7]; lit8
     when {lit8! = n@[24:31]!} is sint32; lit8 = n@[0:7]; lit8 = n@[8:15];
                                          lit8 = n@[16:23]; lit8
  unary n!  is sint(n); unary  

<*>= [D->]
procedure expbc(e)
  local leadingsign, prefix
  static psopstab
  initial {<init>}
  return case type(e) of {
    <cases for expbc>
    default    : &fail
  } | impossible("postfix expression ", image(e), " : ", type(e))
end
Defines expbc (links are to index).

<cases for expbc>= (<-U) [D->]
"list"     : bc_mark() || commaseparate(maplist(expbc, e), "") || bc_array()
"set"      : bc_mark() || commaseparate(sort(maplist(expbc, sort(e))), "") || bc_set()
"eqn"      : expbc(e.left) || expbc(e.right)  || \psopstab[e.op]

<init>= (<-U)
psopstab := table()
psopstab["<"]  := bc_lt()
psopstab["<="] := bc_le()
psopstab[">"]  := bc_gt()
psopstab[">="] := bc_ge()
psopstab["!="] := bc_ne()
psopstab["="]  := bc_eq()

<cases for expbc>+= (<-U) [<-D->]
"table"    : {                      # standard normal form
    <make s represent table e>
    s 
  }
"string"   : bc_stringout(e)
"literal"  : bc_stringout(e.s) || bc_lit()
"integer"  : bc_sint(e)
"null"     : bc_null()

<*>+= [<-D->]
procedure bc_stringout(s)
  return bc_stringlit() || bc_sint(*s) || s
end
Defines bc_stringout (links are to index).

Be sure to omit multiplicative and additive units. Otherwise, it doesn't matter. 

<make s represent table e>= (<-U)
{
  s := ""; firstterm := 1
  t := table(0)
  l := []
  every e[k := 1 ~=== key(e)] do {
    type(k) ~== "integer" | impossible("key ", k, " in ", expimage(e))
    put(l, x := expbc(k))
    t[x] +:= e[k]
  }
  l := sort(l)
  every x := !l & t[x] > 0 do {
    s ||:= bcx(x, t[x], firstterm)
    firstterm := &null
  }
  every x := !l & t[x] < 0 do {
    s ||:= bcx(x, t[x], firstterm)
    firstterm := &null
  }
  if \firstterm then
    s ||:= bc_sint(e[1])
  else if e[1] ~= 0 then 
    s ||:= bc_addlit(e[1])
}

<*>+= [<-D->]
procedure bcx(x, mul, firstterm)
  return if \firstterm then case mul of {
            1 : x
           -1 : x || bc_neg()
           default : x || bc_sint(mul) || bc_mul()
         } else case mul of {
            1 : x || bc_add()
           -1 : x || bc_sub()
           default : x || bc_sint(mul) || bc_mul() || bc_add()
         }
end
Defines bcx (links are to index).

<cases for expbc>+= (<-U) [<-D->]
"Eorb"     : { l := sort(maplist(expbc, flatten(e, type(e))))
               s := l[1]
               every s ||:= l[2 to *l] || bc_orb()
               s
             }
"Eand"     : { l := sort(maplist(expbc, flatten(e, type(e))))
               s := l[1]
               every s ||:= l[2 to *l] || bc_and()
               s
             }

<cases for expbc>+= (<-U) [<-D->]
"Eslice"   : expbc(e.x) || bc_bitslice(e.lo, e.lo + e.n - 1)
"Eshift"   : expbc(e.x) || bc_bitshift(e.n)

<cases for expbc>+= (<-U) [<-D->]
"Enarrowu" : expbc(e.x) || bc_narrowu(e.n)
"Enarrows" : expbc(e.x) || bc_narrows(e.n)
"Ewiden"   : expbc(e.x) || bc_widen(e.n)

<cases for expbc>+= (<-U) [<-D->]
"Ediv"     : expbc(e.x) || bc_sint(e.n) || bc_idiv()
"Emod"     : expbc(e.x) || bc_sint(e.n) || bc_mod()

<cases for expbc>+= (<-U) [<-D->]
"Semit"    : commaseparate(maplist(expbc, e.x), "") 
"Stoken"   : expbc(e.x) ||
               if e.offset = 0 then bc_emit_at_loc(e.n)
               else bc_cl_loc() || bc_force() || bc_addlit(e.offset) || bc_emit_at(e.n)

<cases for expbc>+= (<-U) [<-D->]
"Efitsu"   : expbc(e.x) || bc_fitsu(e.n)
"Efitss"   : expbc(e.x) || bc_fitss(e.n)

<cases for expbc>+= (<-U) [<-D->]
"Epatlabel" : &fail

<cases for expbc>+= (<-U) [<-D->]
"Eforce"    : 
  case type(e.x) of {
    "Eclosure_addr" : bc_cla_force(e.x.n)
    "Eclosure_loc"  : bc_cl_loc_force()
    default         : expbc(e.x) || bc_force()
  }
"Eforceable": expbc(e.x) || bc_known()

<cases for expbc>+= (<-U) [<-D->]
"Epc"       : &fail
"Epc_known" : &fail

<cases for expbc>+= (<-U) [<-D->]
"Enot"      : expbc(e.x) || bc_not()

<cases for expbc>+= (<-U) [<-D->]
"Enosimp"   : expbc(e.x)

<cases for expbc>+= (<-U) [<-D->]
"Sstmts"    : commaseparate(maplist(expbc, e.x), "")

<cases for expbc>+= (<-U) [<-D->]
"Einstance" : &fail
"Einstance_input" : &fail 
"Einstance_tagged" : &fail
"Ebinding_instance" : &fail

<cases for expbc>+= (<-U) [<-D->]
"Sif"      : { s := bc_mark()
               every s ||:= expbc(!e.arms)
               s || bc_array() || bc_if_guard()
             }
"Sguarded" : bcguard(e.guard) || bc_procmark() || expbc(e.x) || bc_proc()

<*>+= [<-D]
procedure bcguard(e)
  return case type(e) of {
    "integer" : case e of { 0 : bc_false(); 1 : bc_true()
                            default: impossible("condition") }
    "null" : bc_true()
    "set" : {
       l := sort(maplist(expbc, sort(e)))
       s := l[1]
       every s ||:= l[2 to *l] || bc_and()
       if *l = 0 then bc_true() else s
    }
    default : expbc(e)
  }
end
Defines bcguard (links are to index).

<cases for expbc>+= (<-U) [<-D->]
"Stagcase" : &fail

<cases for expbc>+= (<-U) [<-D->]
"Sfail"    : if e.fmt ~== "Conditions not satisfied for unnamed constructor" |
                \(e.a1|e.a2|e.a3)
             then {
               s := bc_stringout(e.fmt) || bc_mark()
               every a := e.a1 | e.a2 | e.a3 do 
                 s ||:= expbc(\a)
               s ||:= bc_array() || bc_failmsg()
             } else
               bc_unsat()
"Sepsilon" : ""

<cases for expbc>+= (<-U) [<-D->]
"Efail"    : &fail

<cases for expbc>+= (<-U) [<-D->]
"Glines"    : commaseparate(maplist2(expbc, e.x), "")
"Gresynch"  : ""
"Gblock"    : &fail
"Gdecl"     : &fail

<cases for expbc>+= (<-U) [<-D->]
"Gcase"     : &fail
"Gcasearm"  : &fail
"Ginrange"  : &fail

<cases for expbc>+= (<-U) [<-D->]
"Gasgn"     : &fail
"Gsetname"  : &fail
"Gnomatch"  : &fail
"Tunsigned" : &fail

<cases for expbc>+= (<-U) [<-D->]
"Eapp" : &fail

<cases for expbc>+= (<-U) [<-D->]
"Eclosure_loc"  : bc_cl_loc()
"Eclosure_addr" : bc_cla(e.n)
"Eclosure_val"  : bc_clv(e.n)

<cases for expbc>+= (<-U) [<-D]
"Eclosure" : &fail
"Elambda" :  &fail