~plan/plunder

35c797c34bd30824efcb54f1ea6712e0496d33c3 — Sol 4 months ago 99829ca
viceroy: codegen for #case
1 files changed, 111 insertions(+), 6 deletions(-)

M sire/viceroy.sire
M sire/viceroy.sire => sire/viceroy.sire +111 -6
@@ 118,6 118,7 @@
- EREF Nat
- EAPP Exp Exp
- ETUP Row-Exp
- ECAS Exp (Tab Nat (Row Maybe-Str, Exp))
- ELET nm/Str vTy/Type v/Exp b/Exp
- EFUN inline/Bit pin/Bit nm/Str Row-(Exp,Type) rTy/Type b/Exp



@@ 474,6 475,97 @@ abstype#(Bst k v)
  | [1=(K 1) 2=(K 2) 3=(K 3)]


;;; ADT Switch Codegen ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Here, we do some analysis on case expressions. For example, given
;;; this expression:
;;;
;;;     # case (foo bar baz)
;;;     - FOO _ a _ _ | [%FOO _ a _ _]
;;;     - BAR _ x y _ | [%BAR _ x y _]
;;;
;;; We will need to bind:
;;;
;;;     @ scrut (foo bar baz)
;;;     @ f1    (idx-2 scrut)
;;;     @ f2    (idx-3 scrut)
;;;
;;; Which will require this sequence of let-binds:
;;;
;;;     | L (A (A foo bar) baz)
;;;     | L (A K-(idx 2) V-1)
;;;     | L (A K-(idx 3) V-2)
;;;     | ...
;;;
;;; And then, on each branch, we need to update the environment to map
;;; names to these new fields.  Those names will be different in each
;;; branch, because the array-slots mean different things in each branch.
;;; we assign different names to these bindings:
;;;
;;;     FOO: [NONE SOME-{a} NONE]
;;;
;;;     BAR: [NONE SOME-{x} SOME-{y}]
;;;
;;; {caseSlots} looks at each branch, determines which array-elements
;;; are needed from each, and produces a set of slot-indexes.
;;;
;;; {caseBinds} analyses the pattern-match and produces:
;;;
;;; -   a row of let-bindings needed to pull all of the required fields
;;;     into scope.
;;;
;;; -   for each branch, A row of names corresponding to these binds.

> Tab Nat (Row (Maybe Str), Exp) > Set Nat
= (caseSlots branches)
^ foldl _ %[] (tabValsRow branches)
& (need branch@(fields, exp))
^ setWeld need (setFromRow | catMaybes _)
: [i [mf _]] < foreach (rowIndexed fields)
| ifz mf NONE (SOME i)

> Sire
> Tab Nat (Row (Maybe Str), a)
> (Row Sire, Tab Nat (Row (Maybe Str)))
= (caseBinds adtSire branches)
@ slots    | caseSlots branches
@ numBinds | inc (setLen slots)
++
    ^ sizedListToRow numBinds adtSire::_
    : [bindNum fieldIx] < listForEach (listIndexed | setToList slots)
    | A K-(idx | inc fieldIx) V-(inc bindNum)
++
    ^ tabMap _ branches
    & (fields, expr)
    | sizedListToRow numBinds
    | (NONE :: listMap (get fields) (setToList slots))

=?= %[1 2 4]
  | caseSlots ## =3 ([NONE SOME-{x} SOME-{y}], EREF-{y})
              ## =9 ([NONE NONE NONE NONE SOME-{z}], EREF-{z})

=?=  ++   ++ K {lol}
          ++ A K-(idx 2) V-1
          ++ A K-(idx 3) V-2
          ++ A K-(idx 5) V-3
     ++   ## =3 [0 SOME-{x} SOME-{y} 0]
          ## =9 [0 0 0 SOME-{z}]
  | caseBinds K-{lol}
 ## =3 ([NONE SOME-{x} SOME-{y}], EREF-{y})
 ## =9 ([NONE NONE NONE NONE SOME-{z}], EREF-{z})

> _ > _ > Exp > Tab Nat (Row (Maybe Str), Exp) > Sire
= (compileCase go e scrut branches)
@ (binds, envs) | caseBinds (go e scrut) branches
^ foldr L _ binds
| switchSire (A K-dataTag V-(len binds)) K-{fallback}
| tabFromPairsList
: tag    < listForEach (tabKeysList branches)
@ enu    | listFromRowRev (tabIdx tag envs)
@ (_, x) | tabIdx tag branches
| (tag, go (listWeld enu e) x)


;;; Misc Codegen ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

= (addSire a b) | apple (G getBind#add) [a b]


@@ 488,12 580,13 @@ abstype#(Bst k v)
    ? (go e exp)
    # case exp

    - EBIT n   | K n
    - ENAT n   | K n
    - EAPP a b | A (go e a) (go e b)
    - EADD a b | addSire (go e a) (go e b)
    - EEQL a b | eqlSire (go e a) (go e b)
    - ETUP xs  | rowSire (map go-e xs)
    - EBIT n    | K n
    - ENAT n    | K n
    - EAPP a b  | A (go e a) (go e b)
    - EADD a b  | addSire (go e a) (go e b)
    - EEQL a b  | eqlSire (go e a) (go e b)
    - ETUP xs   | rowSire (map go-e xs)
    - ECAS s bs | compileCase go e s bs

    - EREF x
        @ rex (WORD x 0)


@@ 515,6 608,18 @@ abstype#(Bst k v)

    - _ (die {malformed ast},exp)

=?=   | L (K {ADT})
      | L (A K-(idx 2) V-1)
      | L (A K-(idx 3) V-2)
      | L (A K-(idx 5) V-3)
      ^ apple K-tabSwitch (A K-dataTag V-4, K-{fallback}, tabSire _)
     ## =3 | addSire V-2 V-1
     ## =9 | V-0
  ^ | compile (5, {REPL}, #[], #[])
    | ECAS ENAT-{ADT} _
 ## =3 ([NONE SOME-{x} SOME-{y}], EADD EREF-{x} EREF-{y})
 ## =9 ([NONE NONE NONE NONE SOME-{z}], EREF-{z})


;;; Type-Checking ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;