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, topt, _, e) =>
 115         (case topt of
 116              NONE => expNeeded (Env.bindVal G (x, dt, NONE)) e
 117            | SOME t => unionCTE ((typNeeded G t, SS.empty),
 118                                  expNeeded (Env.bindVal G (x, dt, NONE)) e))
 119       | ESeq es => foldl (fn (e, ss) => unionCTE (ss, expNeeded G e))
 120                    empty es
 121       | ELocal (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 122       | EWith (e1, e2) => unionCTE (expNeeded G e1, expNeeded G e2)
 123
 124 fun declNeeded G (d, _, _) =
 125     case d of
 126         DExternType name => (Env.bindType G name, empty)
 127       | DExternVal (name, t) => (Env.bindVal G (name, dt, NONE),
 128                                  (typNeeded G t, SS.empty))
 129       | DVal (name, to, e) => (Env.bindVal G (name, dt, NONE),
 130                                case to of
 131                                    NONE => expNeeded G e
 132                                  | SOME t => unionCTE ((typNeeded G t, SS.empty),
 133                                                        expNeeded G e))
 134       | DContext name => (Env.bindContext G name, empty)
 135
 136 fun fileSig (_, ds, eo) =
 137     let
 138         val (G', needed) = foldl
 139                            (fn (d, (G, needed)) =>
 140                                let
 141                                    val (G', needed') = declNeeded G d
 142                                in
 143                                    (G', unionCTE (needed, needed'))
 144                                end)
 145                            (Env.empty, empty) ds
 146
 147         val needed =
 148             case eo of
 149                 NONE => needed
 150               | SOME e => unionCTE (needed,
 151                                     expNeeded G' e)
 152     in
 153         (((Env.contexts G', Env.types G'), Env.vals G'),
 154          needed)
 155     end
 156
 157 fun printSig ((cs, ts), vs) =
 158     (print "Contexts:";
 159      SS.app (fn s => (print " "; print s; print ";")) cs;
 160      print "\n   Types:";
 161      SS.app (fn s => (print " "; print s; print ";")) ts;
 162      print "\n  Values:";
 163      SS.app (fn s => (print " "; print s; print ";")) vs;
 164      print "\n")
 165
 166 val allNaughty = ref false
 167 val naughtyFiles = ref SS.empty
 168 fun addNaughty fname = naughtyFiles := SS.add (!naughtyFiles, fname)
 169
 170 fun mergeProvide kind fname (m1, m2) =
 171     SS.foldl (fn (name, provide) =>
 172                  (case SM.find (provide, name) of
 173                       NONE => ()
 174                     | SOME fname' =>
 175                       (addNaughty fname;
 176                        addNaughty fname';
 177                        ErrorMsg.error NONE (String.concat ["Files ",
 178                                                            fname',
 179                                                            " and ",
 180                                                            fname,
 181                                                            " both provide ",
 182                                                            kind,
 183                                                            " ",
 184                                                            name]));
 185                   SM.insert (provide, name, fname)))
 186     m1 m2
 187
 188 fun order basisOpt fnames =
 189     let
 190         val () = allNaughty := false
 191         val () = naughtyFiles := SS.empty
 192
 193         fun doFile (fname, (provideC, provideT, provideV, require)) =
 194             let
 195                 val file = Parse.parse fname
 196                 val (((provideC', provideT'), provideV'),
 197                      require') = fileSig file
 198             in
 199                 (mergeProvide "context" fname (provideC, provideC'),
 200                  mergeProvide "type" fname (provideT, provideT'),
 201                  mergeProvide "value" fname (provideV, provideV'),
 202                  SM.insert (require, fname, require'))
 203             end
 204
 205         val (provideC, provideT, provideV, require) =
 206             foldl doFile (SM.empty, SM.empty, SM.empty, SM.empty) fnames
 207
 208         val require = SM.mapi (fn (fname, ((rc, rt), rv)) =>
 209                                   let
 210                                       fun consider (kind, provide, lastChance) =
 211                                           SS.foldl (fn (name, need) =>
 212                                                        case SM.find (provide, name) of
 213                                                            NONE =>
 214                                                            if lastChance name then
 215                                                                need
 216                                                            else
 217                                                                (addNaughty fname;
 218                                                                 ErrorMsg.error NONE
 219                                                                                ("File "
 220                                                                                 ^ fname
 221                                                                                 ^ " uses undefined "
 222                                                                                 ^ kind
 223                                                                                 ^ " "
 224                                                                                 ^ name);
 225                                                                 need)
 226                                                          | SOME fname' =>
 227                                                            SS.add (need, fname'))
 228
 229                                       val need = consider ("context", provideC,
 230                                                            case basisOpt of
 231                                                                NONE => (fn _ => false)
 232                                                              | SOME b => Env.lookupContext b)
 233                                                           SS.empty rc
 234                                       val need = consider ("type", provideT,
 235                                                            case basisOpt of
 236                                                                NONE => (fn _ => false)
 237                                                              | SOME b => Env.lookupType b)
 238                                                           need rt
 239                                       val need = consider ("value", provideV,
 240                                                            case basisOpt of
 241                                                                NONE => (fn _ => false)
 242                                                              | SOME b => (fn name => Option.isSome (Env.lookupVal b name)))
 243                                                           need rv
 244                                   in
 245                                       need
 246                                   end) require
 247
 248         fun loop (ready, waiting, order) =
 249             case SS.find (fn _ => true) ready of
 250                 NONE =>
 251                 if SM.numItems waiting = 0 then
 252                     rev order
 253                 else
 254                     (allNaughty := true;
 255                      ErrorMsg.error NONE "Cyclic dependency in source files";
 256                      order)
 257               | SOME next =>
 258                 let
 259                     val (ready', waiting') =
 260                         SM.foldli (fn (fname, requires, (ready', waiting')) =>
 261                                       let
 262                                           val requires' = SS.delete (requires, next)
 263                                               handle NotFound => requires
 264                                       in
 265                                           if SS.numItems requires' = 0 then
 266                                               (SS.add (ready', fname),
 267                                                waiting')
 268                                           else
 269                                               (ready',
 270                                                SM.insert (waiting', fname, requires'))
 271                                       end)
 272                                   (SS.delete (ready, next), SM.empty) waiting
 273                 in
 274                     loop (ready', waiting', next :: order)
 275                 end
 276
 277         val (ready, waiting) =
 278             SM.foldli (fn (fname, requires, (ready, waiting)) =>
 279                           if SS.numItems requires = 0 then
 280                               (SS.add (ready, fname),
 281                                waiting)
 282                           else
 283                               (ready,
 284                                SM.insert (waiting, fname, requires)))
 285                       (SS.empty, SM.empty) require
 286
 287         val ordered = loop (ready, waiting, [])
 288         val provider = {provideC = provideC,
 289                         provideT = provideT,
 290                         provideV = provideV}
 291     in
 292         if !allNaughty then
 293             (provider, [])
 294         else if SS.isEmpty (!naughtyFiles) then
 295             (provider, ordered)
 296         else
 297             order basisOpt (List.filter (fn fname => not (SS.member (!naughtyFiles, fname))) fnames)
 298     end
 299
 300 type providers = {provideC : string SM.map,
 301                   provideT : string SM.map,
 302                   provideV : string SM.map}
 303
 304 fun providesContext (p : providers, s) = SM.find (#provideC p, s)
 305 fun providesType (p : providers, s) = SM.find (#provideT p, s)
 306 fun providesValue (p : providers, s) = SM.find (#provideV p, s)
 307
 308 end