elm/Env.elm

   1 module Env
   2     exposing
   3         ( debug
   4         , globalFrameId
   5         , global
   6         , get
   7         , set
   8         , newAtom
   9         , getAtom
  10         , setAtom
  11         , push
  12         , pop
  13         , enter
  14         , leave
  15         , ref
  16         , pushRef
  17         , restoreRefs
  18         , gc
  19         )
  20
  21 import Types exposing (MalExpr(..), MalFunction(..), Frame, Env)
  22 import Dict
  23 import Array
  24 import Set
  25
  26
  27 debug : Env -> String -> a -> a
  28 debug env msg value =
  29     if env.debug then
  30         Debug.log msg value
  31     else
  32         value
  33
  34
  35 globalFrameId : Int
  36 globalFrameId =
  37     0
  38
  39
  40 defaultGcInterval : Int
  41 defaultGcInterval =
  42     10
  43
  44
  45 global : Env
  46 global =
  47     { frames = Dict.singleton globalFrameId (emptyFrame Nothing Nothing)
  48     , nextFrameId = globalFrameId + 1
  49     , currentFrameId = globalFrameId
  50     , atoms = Dict.empty
  51     , nextAtomId = 0
  52     , debug = False
  53     , gcInterval = defaultGcInterval
  54     , gcCounter = 0
  55     , stack = []
  56     , keepFrames = []
  57     }
  58
  59
  60 getFrame : Env -> Int -> Frame
  61 getFrame env frameId =
  62     case Dict.get frameId env.frames of
  63         Just frame ->
  64             frame
  65
  66         Nothing ->
  67             Debug.crash <| "frame #" ++ (toString frameId) ++ " not found"
  68
  69
  70 emptyFrame : Maybe Int -> Maybe Int -> Frame
  71 emptyFrame outerId exitId =
  72     { outerId = outerId
  73     , exitId = exitId
  74     , data = Dict.empty
  75     , refCnt = 1
  76     }
  77
  78
  79 set : String -> MalExpr -> Env -> Env
  80 set name expr env =
  81     let
  82         frameId =
  83             env.currentFrameId
  84
  85         updateFrame =
  86             Maybe.map
  87                 (\frame ->
  88                     { frame | data = Dict.insert name expr frame.data }
  89                 )
  90
  91         newFrames =
  92             Dict.update frameId updateFrame env.frames
  93     in
  94         { env | frames = newFrames }
  95
  96
  97 get : String -> Env -> Result String MalExpr
  98 get name env =
  99     let
 100         go frameId =
 101             let
 102                 frame =
 103                     getFrame env frameId
 104             in
 105                 case Dict.get name frame.data of
 106                     Just value ->
 107                         Ok value
 108
 109                     Nothing ->
 110                         frame.outerId
 111                             |> Maybe.map go
 112                             |> Maybe.withDefault (Err <| "'" ++ name ++ "' not found")
 113     in
 114         go env.currentFrameId
 115
 116
 117 newAtom : MalExpr -> Env -> ( Env, Int )
 118 newAtom value env =
 119     let
 120         atomId =
 121             env.nextAtomId
 122
 123         newEnv =
 124             { env
 125                 | atoms = Dict.insert atomId value env.atoms
 126                 , nextAtomId = atomId + 1
 127             }
 128     in
 129         ( newEnv, atomId )
 130
 131
 132 getAtom : Int -> Env -> MalExpr
 133 getAtom atomId env =
 134     case Dict.get atomId env.atoms of
 135         Just value ->
 136             value
 137
 138         Nothing ->
 139             Debug.crash <| "atom " ++ (toString atomId) ++ " not found"
 140
 141
 142 setAtom : Int -> MalExpr -> Env -> Env
 143 setAtom atomId value env =
 144     { env
 145         | atoms = Dict.insert atomId value env.atoms
 146     }
 147
 148
 149 push : Env -> Env
 150 push env =
 151     let
 152         frameId =
 153             env.nextFrameId
 154
 155         newFrame =
 156             emptyFrame (Just env.currentFrameId) Nothing
 157
 158         bogus =
 159             debug env "push" frameId
 160     in
 161         { env
 162             | currentFrameId = frameId
 163             , frames = Dict.insert frameId newFrame env.frames
 164             , nextFrameId = env.nextFrameId + 1
 165         }
 166
 167
 168 pop : Env -> Env
 169 pop env =
 170     let
 171         frameId =
 172             env.currentFrameId
 173
 174         frame =
 175             getFrame env frameId
 176
 177         bogus =
 178             debug env "pop" frameId
 179     in
 180         case frame.outerId of
 181             Just outerId ->
 182                 { env
 183                     | currentFrameId = outerId
 184                     , frames = Dict.update frameId free env.frames
 185                 }
 186
 187             _ ->
 188                 Debug.crash "tried to pop global frame"
 189
 190
 191 setBinds : List ( String, MalExpr ) -> Frame -> Frame
 192 setBinds binds frame =
 193     case binds of
 194         [] ->
 195             frame
 196
 197         ( name, expr ) :: rest ->
 198             setBinds rest
 199                 { frame | data = Dict.insert name expr frame.data }
 200
 201
 202 {-| Enter a new frame with a set of binds
 203 -}
 204 enter : Int -> List ( String, MalExpr ) -> Env -> Env
 205 enter outerId binds env =
 206     let
 207         frameId =
 208             debug env "enter #" env.nextFrameId
 209
 210         exitId =
 211             env.currentFrameId
 212
 213         newFrame =
 214             setBinds binds (emptyFrame (Just outerId) (Just exitId))
 215     in
 216         { env
 217             | currentFrameId = frameId
 218             , frames = Dict.insert frameId newFrame env.frames
 219             , nextFrameId = env.nextFrameId + 1
 220         }
 221
 222
 223 leave : Env -> Env
 224 leave env =
 225     let
 226         frameId =
 227             debug env "leave #" env.currentFrameId
 228
 229         frame =
 230             getFrame env frameId
 231
 232         exitId =
 233             case frame.exitId of
 234                 Just exitId ->
 235                     exitId
 236
 237                 Nothing ->
 238                     Debug.crash <|
 239                         "frame #"
 240                             ++ (toString frameId)
 241                             ++ " doesn't have an exitId"
 242     in
 243         { env
 244             | currentFrameId = exitId
 245             , frames =
 246                 env.frames
 247                     |> Dict.insert frameId { frame | exitId = Nothing }
 248                     |> Dict.update frameId free
 249         }
 250
 251
 252 {-| Increase refCnt for the current frame,
 253 and all it's parent frames.
 254 -}
 255 ref : Env -> Env
 256 ref env =
 257     let
 258         go frameId env =
 259             let
 260                 frame =
 261                     getFrame env frameId
 262
 263                 newFrame =
 264                     { frame | refCnt = frame.refCnt + 1 }
 265
 266                 newEnv =
 267                     { env | frames = Dict.insert frameId newFrame env.frames }
 268             in
 269                 case frame.outerId of
 270                     Just outerId ->
 271                         go outerId newEnv
 272
 273                     Nothing ->
 274                         newEnv
 275
 276         newEnv =
 277             go env.currentFrameId env
 278     in
 279         { newEnv | gcCounter = newEnv.gcCounter + 1 }
 280
 281
 282 free : Maybe Frame -> Maybe Frame
 283 free =
 284     Maybe.andThen
 285         (\frame ->
 286             if frame.refCnt == 1 then
 287                 Nothing
 288             else
 289                 Just { frame | refCnt = frame.refCnt - 1 }
 290         )
 291
 292
 293 pushRef : MalExpr -> Env -> Env
 294 pushRef ref env =
 295     { env | stack = ref :: env.stack }
 296
 297
 298 restoreRefs : List MalExpr -> Env -> Env
 299 restoreRefs refs env =
 300     { env | stack = refs }
 301
 302
 303 {-| Given an Env see which frames are not reachable from the
 304 global frame, or from the current expression.
 305
 306 Return a new Env with the unreachable frames removed.
 307
 308 -}
 309 gc : MalExpr -> Env -> Env
 310 gc expr env =
 311     let
 312         countList acc =
 313             List.foldl countExpr acc
 314
 315         countFrame { data } acc =
 316             data |> Dict.values |> countList acc
 317
 318         recur frameId acc =
 319             if not (Set.member frameId acc) then
 320                 let
 321                     frame =
 322                         getFrame env frameId
 323
 324                     newAcc =
 325                         Set.insert frameId acc
 326                 in
 327                     countFrame frame newAcc
 328             else
 329                 acc
 330
 331         countBound bound acc =
 332             bound
 333                 |> List.map Tuple.second
 334                 |> countList acc
 335
 336         countExpr expr acc =
 337             case expr of
 338                 MalFunction (UserFunc { frameId }) ->
 339                     recur frameId acc
 340
 341                 MalApply { frameId, bound } ->
 342                     recur frameId acc
 343                         |> countBound bound
 344
 345                 MalList list ->
 346                     countList acc list
 347
 348                 MalVector vec ->
 349                     countList acc (Array.toList vec)
 350
 351                 MalMap map ->
 352                     countList acc (Dict.values map)
 353
 354                 MalAtom atomId ->
 355                     let
 356                         value =
 357                             getAtom atomId env
 358                     in
 359                         countExpr value acc
 360
 361                 _ ->
 362                     acc
 363
 364         initSet =
 365             Set.fromList
 366                 ([ globalFrameId, env.currentFrameId ]
 367                     ++ env.keepFrames
 368                 )
 369
 370         countFrames frames acc =
 371             Set.toList frames
 372                 |> List.map (getFrame env)
 373                 |> List.foldl countFrame acc
 374
 375         expand frameId frame fn acc =
 376             case fn frame of
 377                 Nothing ->
 378                     acc
 379
 380                 Just parentId ->
 381                     Set.insert parentId acc
 382
 383         expandBoth frameId =
 384             let
 385                 frame =
 386                     getFrame env frameId
 387             in
 388                 expand frameId frame .outerId
 389                     >> expand frameId frame .exitId
 390
 391         expandParents frames =
 392             Set.foldl expandBoth frames frames
 393
 394         loop acc =
 395             let
 396                 newAcc =
 397                     expandParents acc
 398
 399                 newParents =
 400                     Set.diff newAcc acc
 401             in
 402                 if Set.isEmpty newParents then
 403                     newAcc
 404                 else
 405                     loop <| countFrames newParents newAcc
 406
 407         makeNewEnv newFrames =
 408             { env
 409                 | frames = newFrames
 410                 , gcCounter = 0
 411             }
 412
 413         keepFilter keep frameId _ =
 414             Set.member frameId keep
 415
 416         filterFrames frames keep =
 417             Dict.filter (keepFilter keep) frames
 418     in
 419         countFrames initSet initSet
 420             |> countExpr expr
 421             |> (flip countList) env.stack
 422             |> loop
 423             |> filterFrames env.frames
 424             |> makeNewEnv