adamc@315: (* Copyright (c) 2008, Adam Chlipala
adamc@315:  * All rights reserved.
adamc@315:  *
adamc@315:  * Redistribution and use in source and binary forms, with or without
adamc@315:  * modification, are permitted provided that the following conditions are met:
adamc@315:  *
adamc@315:  * - Redistributions of source code must retain the above copyright notice,
adamc@315:  *   this list of conditions and the following disclaimer.
adamc@315:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@315:  *   this list of conditions and the following disclaimer in the documentation
adamc@315:  *   and/or other materials provided with the distribution.
adamc@315:  * - The names of contributors may not be used to endorse or promote products
adamc@315:  *   derived from this software without specific prior written permission.
adamc@315:  *
adamc@315:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@315:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@315:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@315:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@315:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@315:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@315:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@315:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@315:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@315:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@315:  * POSSIBILITY OF SUCH DAMAGE.
adamc@315:  *)
adamc@315: 
adamc@315: (* Simplify a Core program by repeating polymorphic function definitions *)
adamc@315: 
adamc@315: structure Unpoly :> UNPOLY = struct
adamc@315: 
adamc@315: open Core
adamc@315: 
adamc@315: structure E = CoreEnv
adamc@315: structure U = CoreUtil
adamc@315: 
adamc@315: structure IS = IntBinarySet
adamc@315: structure IM = IntBinaryMap
adamc@315: 
adamc@315: 
adamc@315: (** The actual specialization *)
adamc@315: 
adamc@315: val liftConInCon = E.liftConInCon
adamc@315: val subConInCon = E.subConInCon
adamc@315: 
adamc@315: val liftConInExp = E.liftConInExp
adamc@315: val subConInExp = E.subConInExp
adamc@315: 
adamc@399: val isOpen = U.Con.exists {kind = fn _ => false,
adamc@399:                            con = fn c =>
adamc@399:                                     case c of
adamc@399:                                         CRel _ => true
adamc@399:                                       | _ => false}
adamc@399: 
adamc@316: fun unpolyNamed (xn, rep) =
adamc@316:     U.Exp.map {kind = fn k => k,
adamc@316:                con = fn c => c,
adamc@316:                exp = fn e =>
adamc@316:                         case e of
adamc@399:                             ECApp (e', _) =>
adamc@325:                             let
adamc@325:                                 fun isTheOne (e, _) =
adamc@325:                                     case e of
adamc@325:                                         ENamed xn' => xn' = xn
adamc@325:                                       | ECApp (e, _) => isTheOne e
adamc@325:                                       | _ => false
adamc@325:                             in
adamc@325:                                 if isTheOne e' then
adamc@399:                                     rep
adamc@325:                                 else
adamc@325:                                     e
adamc@325:                             end
adamc@316:                           | _ => e}
adamc@316: 
adamc@794: structure M = BinaryMapFn(struct
adamc@794:                           type ord_key = con list
adamc@794:                           val compare = Order.joinL U.Con.compare
adamc@794:                           end)
adamc@794: 
adamc@794: type func = {
adamc@794:      kinds : kind list,
adamc@794:      defs : (string * int * con * exp * string) list,
adamc@794:      replacements : int M.map
adamc@794: }
adamc@794: 
adamc@315: type state = {
adamc@794:      funcs : func IM.map,
adamc@315:      decls : decl list,
adamc@315:      nextName : int
adamc@315: }
adamc@315: 
adamc@315: fun kind (k, st) = (k, st)
adamc@315: 
adamc@315: fun con (c, st) = (c, st)
adamc@315: 
adamc@315: fun exp (e, st : state) =
adamc@315:     case e of
adamc@315:         ECApp _ =>
adamc@315:         let
adamc@315:             fun unravel (e, cargs) =
adamc@315:                 case e of
adamc@315:                     ECApp ((e, _), c) => unravel (e, c :: cargs)
adamc@315:                   | ENamed n => SOME (n, rev cargs)
adamc@315:                   | _ => NONE
adamc@315:         in
adamc@315:             case unravel (e, []) of
adamc@315:                 NONE => (e, st)
adamc@315:               | SOME (n, cargs) =>
adamc@399:                 if List.exists isOpen cargs then
adamc@399:                     (e, st)
adamc@399:                 else
adamc@399:                     case IM.find (#funcs st, n) of
adamc@399:                         NONE => (e, st)
adamc@794:                       | SOME {kinds = ks, defs = vis, replacements} =>
adamc@794:                         case M.find (replacements, cargs) of
adamc@794:                             SOME n => (ENamed n, st)
adamc@794:                           | NONE =>
adamc@794:                             let
adamc@794:                                 val old_vis = vis
adamc@794:                                 val (vis, (thisName, nextName)) =
adamc@794:                                     ListUtil.foldlMap
adamc@794:                                         (fn ((x, n', t, e, s), (thisName, nextName)) =>
adamc@794:                                             ((x, nextName, n', t, e, s),
adamc@794:                                              (if n' = n then nextName else thisName,
adamc@794:                                               nextName + 1)))
adamc@794:                                         (0, #nextName st) vis
adamc@315: 
adamc@794:                                 fun specialize (x, n, n_old, t, e, s) =
adamc@794:                                     let
adamc@794:                                         fun trim (t, e, cargs) =
adamc@794:                                             case (t, e, cargs) of
adamc@794:                                                 ((TCFun (_, _, t), _),
adamc@794:                                                  (ECAbs (_, _, e), _),
adamc@794:                                                  carg :: cargs) =>
adamc@794:                                                 let
adamc@794:                                                     val t = subConInCon (length cargs, carg) t
adamc@794:                                                     val e = subConInExp (length cargs, carg) e
adamc@794:                                                 in
adamc@794:                                                     trim (t, e, cargs)
adamc@794:                                                 end
adamc@796:                                               | (_, _, []) => SOME (t, e)
adamc@794:                                               | _ => NONE
adamc@794:                                     in
adamc@794:                                         (*Print.prefaces "specialize"
adamc@794:                                                          [("t", CorePrint.p_con CoreEnv.empty t),
adamc@794:                                                           ("e", CorePrint.p_exp CoreEnv.empty e),
adamc@794:                                                           ("|cargs|", Print.PD.string (Int.toString (length cargs)))];*)
adamc@794:                                         Option.map (fn (t, e) => (x, n, n_old, t, e, s))
adamc@794:                                                    (trim (t, e, cargs))
adamc@794:                                     end
adamc@315: 
adamc@794:                                 val vis = List.map specialize vis
adamc@794:                             in
adamc@794:                                 if List.exists (not o Option.isSome) vis orelse length cargs > length ks then
adamc@794:                                     (e, st)
adamc@794:                                 else
adamc@794:                                     let
adamc@794:                                         val vis = List.mapPartial (fn x => x) vis
adamc@316: 
adamc@794:                                         val vis = map (fn (x, n, n_old, t, e, s) =>
adamc@794:                                                           (x ^ "_unpoly", n, n_old, t, e, s)) vis
adamc@794:                                         val vis' = map (fn (x, n, _, t, e, s) =>
adamc@794:                                                            (x, n, t, e, s)) vis
adamc@794: 
adamc@1016:                                         val funcs = foldl (fn ((_, n, n_old, _, _, _), funcs) =>
adamc@1016:                                                               let
adamc@1016:                                                                   val replacements = case IM.find (funcs, n_old) of
adamc@1016:                                                                                          NONE => M.empty
adamc@1016:                                                                                        | SOME {replacements = r, ...} => r
adamc@1016:                                                               in
adamc@1016:                                                                   IM.insert (funcs, n_old,
adamc@1016:                                                                              {kinds = ks,
adamc@1016:                                                                               defs = old_vis,
adamc@1016:                                                                               replacements = M.insert (replacements,
adamc@1016:                                                                                                        cargs,
adamc@1016:                                                                                                        n)})
adamc@1016:                                                               end) (#funcs st) vis
adamc@794: 
adamc@794:                                         val ks' = List.drop (ks, length cargs)
adamc@794: 
adamc@794:                                         val st = {funcs = foldl (fn (vi, funcs) =>
adamc@794:                                                                     IM.insert (funcs, #2 vi,
adamc@794:                                                                                {kinds = ks',
adamc@794:                                                                                 defs = vis',
adamc@794:                                                                                 replacements = M.empty}))
adamc@794:                                                                 funcs vis',
adamc@794:                                                   decls = #decls st,
adamc@794:                                                   nextName = nextName}
adamc@794: 
adamc@794:                                         val (vis', st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
adamc@794:                                                                                let
adamc@794:                                                                                    val (e, st) = polyExp (e, st)
adamc@794:                                                                                in
adamc@794:                                                                                    ((x, n, t, e, s), st)
adamc@794:                                                                                end)
adamc@794:                                                                            st vis'
adamc@794:                                     in
adamc@794:                                         (ENamed thisName,
adamc@794:                                          {funcs = #funcs st,
adamc@399:                                           decls = (DValRec vis', ErrorMsg.dummySpan) :: #decls st,
adamc@794:                                           nextName = #nextName st})
adamc@794:                                     end
adamc@794:                             end
adamc@315:         end
adamc@315:       | _ => (e, st)
adamc@315: 
adamc@794: and polyExp (x, st) = U.Exp.foldMap {kind = kind, con = con, exp = exp} st x
adamc@794: 
adamc@315: fun decl (d, st : state) =
adamc@1122:     let
adamc@1122:         fun unravel (e, cargs) =
adamc@1122:             case e of
adamc@1122:                 (ECAbs (_, k, e), _) =>
adamc@1122:                 unravel (e, k :: cargs)
adamc@1122:               | _ => rev cargs
adamc@1122:     in
adamc@1122:         case d of
adamc@1122:             DVal (vi as (x, n, t, e, s)) =>
adamc@1122:             let
adamc@1122:                 val cargs = unravel (e, [])
adamc@315: 
adamc@1122:                 val ns = IS.singleton n
adamc@1122:             in
adamc@1122:                 (d, {funcs = IM.insert (#funcs st, n, {kinds = cargs,
adamc@1122:                                                        defs = [vi],
adamc@1122:                                                        replacements = M.empty}),
adamc@1122:                      decls = #decls st,
adamc@1122:                      nextName = #nextName st})
adamc@1122:             end
adamc@1122:           | DValRec (vis as ((x, n, t, e, s) :: rest)) =>
adamc@1122:             let
adamc@1122:                 val cargs = unravel (e, [])
adamc@315: 
adamc@1122:                 fun unravel (e, cargs) =
adamc@1122:                     case (e, cargs) of
adamc@1122:                         ((ECAbs (_, k, e), _), k' :: cargs) =>
adamc@1122:                         U.Kind.compare (k, k') = EQUAL
adamc@1122:                         andalso unravel (e, cargs)
adamc@1122:                       | (_, []) => true
adamc@1122:                       | _ => false
adamc@1122:                              
adamc@1122:                 fun deAbs (e, cargs) =
adamc@1122:                     case (e, cargs) of
adamc@1122:                         ((ECAbs (_, _, e), _), _ :: cargs) => deAbs (e, cargs)
adamc@1122:                       | (_, []) => e
adamc@1122:                       | _ => raise Fail "Unpoly: deAbs"
adamc@315: 
adamc@1122:             in
adamc@1122:                 if List.exists (fn vi => not (unravel (#4 vi, cargs))) rest then
adamc@1122:                     (d, st)
adamc@1122:                 else
adamc@1122:                     let
adamc@1122:                         val ns = IS.addList (IS.empty, map #2 vis)
adamc@1122:                         val nargs = length cargs
adamc@315: 
adamc@1122:                         (** Verifying lack of polymorphic recursion *)
adamc@315: 
adamc@1122:                         fun kind _ = false
adamc@1122:                         fun con _ = false
adamc@315: 
adamc@1122:                         fun exp e =
adamc@1122:                             case e of
adamc@1122:                                 ECApp (e, c) =>
adamc@1122:                                 let
adamc@1122:                                     fun isIrregular (e, pos) =
adamc@1122:                                         case #1 e of
adamc@1122:                                             ENamed n =>
adamc@1122:                                             IS.member (ns, n)
adamc@1122:                                             andalso
adamc@1122:                                             (case #1 c of
adamc@1122:                                                  CRel i => i <> nargs - pos
adamc@1122:                                                | _ => true)
adamc@1122:                                           | ECApp (e, _) => isIrregular (e, pos + 1)
adamc@1122:                                           | _ => false
adamc@1122:                                 in
adamc@1122:                                     isIrregular (e, 1)
adamc@1122:                                 end
adamc@1122:                               | ECAbs _ => true
adamc@1122:                               | _ => false
adamc@315: 
adamc@1122:                         val irregular = U.Exp.exists {kind = kind, con = con, exp = exp}
adamc@1122:                     in
adamc@1122:                         if List.exists (fn x => irregular (deAbs (#4 x, cargs))) vis then
adamc@1122:                             (d, st)
adamc@1122:                         else
adamc@1122:                             (d, {funcs = foldl (fn (vi, funcs) =>
adamc@1122:                                                    IM.insert (funcs, #2 vi, {kinds = cargs,
adamc@1122:                                                                              defs = vis,
adamc@1122:                                                                              replacements = M.empty}))
adamc@1122:                                                (#funcs st) vis,
adamc@1122:                                  decls = #decls st,
adamc@1122:                                  nextName = #nextName st})
adamc@1122:                     end
adamc@1122:             end
adamc@315: 
adamc@1122:           | _ => (d, st)
adamc@1122:     end
adamc@315: 
adamc@315: val polyDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl}
adamc@315: 
adamc@315: fun unpoly file =
adamc@315:     let
adamc@315:         fun doDecl (d : decl, st : state) =
adamc@315:             let
adamc@315:                 val (d, st) = polyDecl st d
adamc@315:             in
adamc@315:                 (rev (d :: #decls st),
adamc@315:                  {funcs = #funcs st,
adamc@315:                   decls = [],
adamc@315:                   nextName = #nextName st})
adamc@315:             end
adamc@315: 
adamc@315:         val (ds, _) = ListUtil.foldlMapConcat doDecl
adamc@315:                       {funcs = IM.empty,
adamc@315:                        decls = [],
adamc@315:                        nextName = U.File.maxName file + 1} file
adamc@315:     in
adamc@315:         ds
adamc@315:     end
adamc@315: 
adamc@315: end