src/order.sml

   1 (* HCoop Domtool (http://hcoop.sourceforge.net/)
   2  * Copyright (c) 2006, Adam Chlipala
   3  *
   4  * This program is free software; you can redistribute it and/or
   5  * modify it under the terms of the GNU General Public License
   6  * as published by the Free Software Foundation; either version 2
   7  * of the License, or (at your option) any later version.
   8  *
   9  * This program is distributed in the hope that it will be useful,
  10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12  * GNU General Public License for more details.
  13  *
  14  * You should have received a copy of the GNU General Public License
  15  * along with this program; if not, write to the Free Software
  16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
  17  *)
  18
  19 (* Topological sorting of source files to take dependencies into account *)
  20
  21 structure Order :> ORDER = struct
  22
  23 open Ast
  24
  25 structure SS = StringSet
  26 structure SM = StringMap
  27
  28 fun predNeeded G (p, _) =
  29     case p of
  30         CRoot => SS.empty
  31       | CConst s =>
  32         if Env.lookupContext G s then
  33             SS.empty
  34         else
  35             SS.singleton s
  36       | CPrefix p => predNeeded G p
  37       | CNot p => predNeeded G p
  38       | CAnd (p1, p2) => SS.union (predNeeded G p1, predNeeded G p2)
  39
  40 fun unionCT ((c1, t1), (c2, t2)) = (SS.union (c1, c2), SS.union (t1, t2))
  41
  42 fun typNeeded G (t, _) =
  43     case t of
  44         TBase s =>
  45         if Env.lookupType G s then
  46             (SS.empty, SS.empty)
  47         else
  48             (SS.empty, SS.singleton s)
  49       | TList t => typNeeded G t
  50       | TArrow (t1, t2) => unionCT (typNeeded G t1, typNeeded G t2)
  51       | TAction (p, d, r) =>
  52         let
  53             val recordNeeded = SM.foldl
  54                                    (fn (t, ss) => unionCT (ss, typNeeded G t))
  55         in
  56             recordNeeded (recordNeeded (predNeeded G p, SS.empty) d) r
  57         end
  58       | TNested (p, t) => unionCT ((predNeeded G p, SS.empty),
  59                                    typNeeded G t)
  60
  61       | TError => raise Fail "TError during dependency analysis"
  62       | TUnif _ => raise Fail "TUnif during dependency analysis"
  63
  64 val empty = ((SS.empty, SS.empty), SS.empty)
  65
  66 fun unionCTE (((c1, t1), v1), ((c2, t2), v2)) =
  67     ((SS.union (c1, c2),
  68       SS.union (t1, t2)),
  69      SS.union (v1, v2))
  70
  71 val dt = (TError, ErrorMsg.dummyLoc)
  72
  73 fun expNeeded G (e, loc) =
  74     case e of
  75         EInt _ => ((SS.empty,
  76                     if Env.lookupType G "int" then
  77                         SS.empty
  78                     else
  79                         SS.singleton "int"),
  80                    SS.empty)
  81       | EString _ => ((SS.empty,
  82                        if Env.lookupType G "string" then
  83                            SS.empty
  84                        else
  85                            SS.singleton "string"),
  86                       SS.empty)
  87       | EList es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
  88                           empty es
  89
  90       | ELam (x, to, e) =>
  91         let
  92             val G' = Env.bindVal G (x, dt, NONE)
  93         in
  94             case to of
  95                 NONE => expNeeded G' e
  96               | SOME t => unionCTE ((typNeeded G t, SS.empty),
  97                                     expNeeded G' e)
  98         end
  99       | EALam (x, p, e) =>
 100         let
 101             val G' = Env.bindVal G (x, (TAction (p, StringMap.empty, StringMap.empty), loc), NONE)
 102         in
 103             unionCTE (((predNeeded G p, SS.empty), SS.empty),
 104                       expNeeded G' e)
 105         end
 106       | EVar x =>
 107         (case Env.lookupVal G x of
 108              NONE => ((SS.empty, SS.empty), SS.singleton x)
 109            | _ => empty)
 110       | EApp (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 111
 112       | ESkip => empty
 113       | ESet (_, e) => expNeeded G e
 114       | EGet (x, _, e) => expNeeded (Env.bindVal G (x, dt, NONE)) e
 115       | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
 116                    empty es
 117       | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 118       | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 119
 120 fun declNeeded G (d, _, _) =
 121     case d of
 122         DExternType name => (Env.bindType G name, empty)
 123       | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
 124                                  (typNeeded G t, SS.empty))
 125       | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
 126                                case to of
 127                                    NONE => expNeeded G e
 128                                  | SOME t => unionCTE ((typNeeded G t, SS.empty),
 129                                                        expNeeded G e))
 130       | DContext name => (Env.bindContext G name, empty)
 131
 132 fun fileSig (_, ds, eo) =
 133     let
 134         val (G', needed) = foldl
 135                            (fn (d, (G, needed)) =>
 136                                let
 137                                    val (G', needed') = declNeeded G d
 138                                in
 139                                    (G', unionCTE (needed, needed'))
 140                                end)
 141                            (Env.empty, empty) ds
 142
 143         val needed =
 144             case eo of
 145                 NONE => needed
 146               | SOME e => unionCTE (needed,
 147                                     expNeeded G' e)
 148     in
 149         (((Env.contexts G', Env.types G'), Env.vals G'),
 150          needed)
 151     end
 152
 153 fun printSig ((cs, ts), vs) =
 154     (print "Contexts:";
 155      SS.app (fn s => (print " "; print s; print ";")) cs;
 156      print "\n   Types:";
 157      SS.app (fn s => (print " "; print s; print ";")) ts;
 158      print "\n  Values:";
 159      SS.app (fn s => (print " "; print s; print ";")) vs;
 160      print "\n")
 161
 162 fun mergeProvide kind fname (m1, m2) =
 163     SS.foldl (fn (name, provide) =>
 164                  (case SM.find (provide, name) of
 165                       NONE => ()
 166                     | SOME fname' => ErrorMsg.error NONE (String.concat ["Files ",
 167                                                                          fname',
 168                                                                          " and ",
 169                                                                          fname,
 170                                                                          " both provide ",
 171                                                                          kind,
 172                                                                          " ",
 173                                                                          name]);
 174                   SM.insert (provide, name, fname)))
 175     m1 m2
 176
 177 fun order fnames =
 178     let
 179         fun doFile (fname, (provideC, provideT, provideV, require)) =
 180             let
 181                 val file = Parse.parse fname
 182                 val (((provideC', provideT'), provideV'),
 183                      require') = fileSig file
 184             in
 185                 (mergeProvide "context" fname (provideC, provideC'),
 186                  mergeProvide "type" fname (provideT, provideT'),
 187                  mergeProvide "value" fname (provideV, provideV'),
 188                  SM.insert (require, fname, require'))
 189             end
 190
 191         val (provideC, provideT, provideV, require) =
 192             foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
 193
 194         val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
 195                                   let
 196                                       fun consider (kind, provide) =
 197                                           SS.foldl (fn (name, need) =>
 198                                                        case SM.find (provide, name) of
 199                                                            NONE => (ErrorMsg.error NONE
 200                                                                     ("File "
 201                                                                      ^ fname
 202                                                                      ^ " uses undefined "
 203                                                                      ^ kind
 204                                                                      ^ " "
 205                                                                      ^ name);
 206                                                                     need)
 207                                                          | SOME fname' =>
 208                                                            SS.add (need, fname'))
 209
 210                                       val need = consider ("context", provideC)
 211                                                           SS.empty rc
 212                                       val need = consider ("type", provideT)
 213                                                           need rt
 214                                       val need = consider ("value", provideV)
 215                                                           need rv
 216                                   in
 217                                       need
 218                                   end) require
 219
 220         fun loop (ready, waiting, order) =
 221             case SS.find (fn _ => true) ready of
 222                 NONE =>
 223                 if SM.numItems waiting = 0 then
 224                     rev order
 225                 else
 226                     (ErrorMsg.error NONE "Cyclic dependency in source files";
 227                      order)
 228               | SOME next =>
 229                 let
 230                     val (ready', waiting') =
 231                         SM.foldli (fn (fname, requires, (ready', waiting')) =>
 232                                       let
 233                                           val requires' = SS.delete (requires, next)
 234                                               handle NotFound => requires
 235                                       in
 236                                           if SS.numItems requires' = 0 then
 237                                               (SS.add (ready', fname),
 238                                                waiting')
 239                                           else
 240                                               (ready',
 241                                                SM.insert (waiting', fname, requires'))
 242                                       end)
 243                                   (SS.delete (ready, next), SM.empty) waiting
 244                 in
 245                     loop (ready', waiting', next :: order)
 246                 end
 247
 248         val (ready, waiting) =
 249             SM.foldli (fn (fname, requires, (ready, waiting)) =>
 250                           if SS.numItems requires = 0 then
 251                               (SS.add (ready, fname),
 252                                waiting)
 253                           else
 254                               (ready,
 255                                SM.insert (waiting, fname, requires)))
 256                       (SS.empty, SM.empty) require
 257     in
 258         (*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
 259         SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
 260         SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
 261
 262         (*SM.appi (fn (fname, requires) =>
 263                     (print fname;
 264                      print " requires:";
 265                      SS.app (fn fname' => (print " "; print fname')) requires;
 266                      print "\n")) require;*)
 267
 268         ({provideC = provideC,
 269           provideT = provideT,
 270           provideV = provideV},
 271          loop (ready, waiting, []))
 272     end
 273
 274 type providers = {provideC : string SM.map,
 275                   provideT : string SM.map,
 276                   provideV : string SM.map}
 277
 278 fun providesContext (p : providers, s) = SM.find (#provideC p, s)
 279 fun providesType (p : providers, s) = SM.find (#provideT p, s)
 280 fun providesValue (p : providers, s) = SM.find (#provideV p, s)
 281
 282 end