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 basisOpt 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, lastChance) =
 197                                           SS.foldl (fn (name, need) =>
 198                                                        case SM.find (provide, name) of
 199                                                            NONE =>
 200                                                            if lastChance name then
 201                                                                need
 202                                                            else
 203                                                                (ErrorMsg.error NONE
 204                                                                                ("File "
 205                                                                                 ^ fname
 206                                                                                 ^ " uses undefined "
 207                                                                                 ^ kind
 208                                                                                 ^ " "
 209                                                                                 ^ name);
 210                                                                 need)
 211                                                          | SOME fname' =>
 212                                                            SS.add (need, fname'))
 213
 214                                       val need = consider ("context", provideC,
 215                                                            case basisOpt of
 216                                                                NONE => (fn _ => false)
 217                                                              | SOME b => Env.lookupContext b)
 218                                                           SS.empty rc
 219                                       val need = consider ("type", provideT,
 220                                                            case basisOpt of
 221                                                                NONE => (fn _ => false)
 222                                                              | SOME b => Env.lookupType b)
 223                                                           need rt
 224                                       val need = consider ("value", provideV,
 225                                                            case basisOpt of
 226                                                                NONE => (fn _ => false)
 227                                                              | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
 228                                                           need rv
 229                                   in
 230                                       need
 231                                   end) require
 232
 233         fun loop (ready, waiting, order) =
 234             case SS.find (fn _ => true) ready of
 235                 NONE =>
 236                 if SM.numItems waiting = 0 then
 237                     rev order
 238                 else
 239                     (ErrorMsg.error NONE "Cyclic dependency in source files";
 240                      order)
 241               | SOME next =>
 242                 let
 243                     val (ready', waiting') =
 244                         SM.foldli (fn (fname, requires, (ready', waiting')) =>
 245                                       let
 246                                           val requires' = SS.delete (requires, next)
 247                                               handle NotFound => requires
 248                                       in
 249                                           if SS.numItems requires' = 0 then
 250                                               (SS.add (ready', fname),
 251                                                waiting')
 252                                           else
 253                                               (ready',
 254                                                SM.insert (waiting', fname, requires'))
 255                                       end)
 256                                   (SS.delete (ready, next), SM.empty) waiting
 257                 in
 258                     loop (ready', waiting', next :: order)
 259                 end
 260
 261         val (ready, waiting) =
 262             SM.foldli (fn (fname, requires, (ready, waiting)) =>
 263                           if SS.numItems requires = 0 then
 264                               (SS.add (ready, fname),
 265                                waiting)
 266                           else
 267                               (ready,
 268                                SM.insert (waiting, fname, requires)))
 269                       (SS.empty, SM.empty) require
 270     in
 271         (*SM.appi (fn (name, fname) => print ("Context " ^ name ^ " in " ^ fname ^ "\n")) provideC;
 272         SM.appi (fn (name, fname) => print ("Type " ^ name ^ " in " ^ fname ^ "\n")) provideT;
 273         SM.appi (fn (name, fname) => print ("Value " ^ name ^ " in " ^ fname ^ "\n")) provideV;*)
 274
 275         (*SM.appi (fn (fname, requires) =>
 276                     (print fname;
 277                      print " requires:";
 278                      SS.app (fn fname' => (print " "; print fname')) requires;
 279                      print "\n")) require;*)
 280
 281         ({provideC = provideC,
 282           provideT = provideT,
 283           provideV = provideV},
 284          loop (ready, waiting, []))
 285     end
 286
 287 type providers = {provideC : string SM.map,
 288                   provideT : string SM.map,
 289                   provideV : string SM.map}
 290
 291 fun providesContext (p : providers, s) = SM.find (#provideC p, s)
 292 fun providesType (p : providers, s) = SM.find (#provideT p, s)
 293 fun providesValue (p : providers, s) = SM.find (#provideV p, s)
 294
 295 end