utils/ext-core/Interp.hs

   1 {-
   2 Interprets the subset of well-typed Core programs for which
   3         (a) All constructor and primop applications are saturated
   4         (b) All non-trivial expressions of unlifted kind ('#') are
   5              scrutinized in a Case expression.
   6
   7 This is by no means a "minimal" interpreter, in the sense that considerably
   8 simpler machinary could be used to run programs and get the right answers.
   9 However, it attempts to mirror the intended use of various Core constructs,
  10 particularly with respect to heap usage.  So considerations such as unboxed
  11 tuples, sharing, trimming, black-holing, etc. are all covered.
  12 The only major omission is garbage collection.
  13
  14 Just a sampling of primitive types and operators are included.
  15 -}
  16
  17 module Interp where
  18
  19 import Core
  20 import Printer
  21 import Monad
  22 import Env
  23 import List
  24 import Char
  25 import Prims
  26
  27 data HeapValue =
  28     Hconstr Dcon [Value]       -- constructed value (note: no qualifier needed!)
  29   | Hclos Venv Var Exp         -- function closure
  30   | Hthunk Venv Exp            -- unevaluated thunk
  31   deriving (Show)
  32
  33 type Ptr = Int
  34
  35 data Value =
  36     Vheap Ptr                  -- heap pointer (boxed)
  37   | Vimm PrimValue             -- immediate primitive value (unboxed)
  38   | Vutuple [Value]            -- unboxed tuples
  39   deriving (Show)
  40
  41 type Venv = Env Var Value       -- values of vars
  42
  43 data PrimValue =                -- values of the (unboxed) primitive types
  44     PCharzh Integer             -- actually 31-bit unsigned
  45   | PIntzh Integer              -- actually WORD_SIZE_IN_BITS-bit signed
  46   | PWordzh Integer             -- actually WORD_SIZE_IN_BITS-bit unsigned
  47   | PAddrzh Integer             -- actually native pointer size
  48   | PFloatzh Rational           -- actually 32-bit
  49   | PDoublezh Rational          -- actually 64-bit
  50 --  etc., etc.
  51   deriving (Eq,Show)
  52
  53 type Menv = Env Mname Venv      -- modules
  54
  55 initialGlobalEnv :: Menv
  56 initialGlobalEnv =
  57     efromlist
  58         [(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
  59
  60 {- Heap management. -}
  61 {- Nothing is said about garbage collection. -}
  62
  63 data Heap = Heap Ptr (Env Ptr HeapValue) -- last cell allocated; environment of allocated cells
  64   deriving (Show)
  65
  66 hallocate :: Heap -> HeapValue -> (Heap,Ptr)
  67 hallocate (Heap last contents) v =
  68    let next = last+1
  69    in (Heap next (eextend contents (next,v)),next)
  70
  71 hupdate :: Heap -> Ptr -> HeapValue -> Heap
  72 hupdate (Heap last contents) p v =
  73    Heap last (eextend contents (p,v))
  74
  75 hlookup:: Heap -> Ptr -> HeapValue
  76 hlookup (Heap _ contents) p =
  77    case elookup contents p of
  78      Just v -> v
  79      Nothing -> error "Missing heap entry (black hole?)"
  80
  81 hremove :: Heap -> Ptr -> Heap
  82 hremove (Heap last contents) p =
  83    Heap last (eremove contents p)
  84
  85 hempty :: Heap
  86 hempty = Heap 0 eempty
  87
  88 {- The evaluation monad manages the heap and the possiblity
  89    of exceptions. -}
  90
  91 type Exn = Value
  92
  93 newtype Eval a = Eval (Heap -> (Heap,Either a Exn))
  94
  95 instance Monad Eval where
  96   (Eval m) >>= k = Eval (
  97              \h -> case m h of
  98                     (h',Left x) -> case k x of
  99                                      Eval k' -> k' h'
 100                     (h',Right exn) -> (h',Right exn))
 101   return x = Eval (\h -> (h,Left x))
 102
 103 hallocateE :: HeapValue -> Eval Ptr
 104 hallocateE v = Eval (\ h ->
 105    let (h',p) = hallocate h v
 106    in (h', Left p))
 107
 108 hupdateE :: Ptr -> HeapValue -> Eval ()
 109 hupdateE p v = Eval (\h -> (hupdate h p v,Left ()))
 110
 111 hlookupE :: Ptr -> Eval HeapValue
 112 hlookupE p =  Eval (\h -> (h,Left (hlookup h p)))
 113
 114 hremoveE :: Ptr -> Eval ()
 115 hremoveE p = Eval (\h -> (hremove h p, Left ()))
 116
 117 raiseE :: Exn -> Eval a
 118 raiseE exn = Eval (\h -> (h,Right exn))
 119
 120 catchE :: Eval a -> (Exn -> Eval a) -> Eval a
 121 catchE (Eval m) f = Eval
 122                        (\h -> case m h of
 123                                (h',Left x) -> (h',Left x)
 124                                (h',Right exn) ->
 125                                        case f exn of
 126                                          Eval f' -> f' h')
 127
 128 runE :: Eval a -> a
 129 runE (Eval f) =
 130   case f hempty of
 131     (_,Left v) -> v
 132     (_,Right exn) ->  error ("evaluation failed with uncaught exception: " ++ show exn)
 133
 134
 135 {- Main entry point -}
 136 evalProgram :: [Module] -> Value
 137 evalProgram modules =
 138  runE(
 139   do globalEnv <- foldM evalModule initialGlobalEnv modules
 140      Vutuple [_,v] <- evalExp globalEnv eempty (App (Var ("Main","main")) (Var (primMname,"realWorldzh")))
 141      return v)
 142
 143 {- Environments:
 144
 145 Evaluating a module just fills an environment with suspensions for all
 146 the external top-level values; it doesn't actually do any evaluation
 147 or look anything up.
 148
 149 By the time we actually evaluate an expression, all external values from
 150 all modules will be in globalEnv.  So evaluation just maintains an environment
 151 of non-external values (top-level or local).  In particular, only non-external
 152 values end up in closures (all other values are accessible from globalEnv.)
 153
 154 Throughout:
 155
 156 - globalEnv contains external values (all top-level) from all modules seen so far.
 157
 158 In evalModule:
 159
 160 - e_venv    contains external values (all top-level) seen so far in current module
 161 - l_venv    contains non-external values (top-level or local)
 162                  seen so far in current module.
 163 In evalExp:
 164
 165 - env       contains non-external values (top-level or local) seen so far
 166                 in current expression.
 167 -}
 168
 169
 170 evalModule :: Menv -> Module -> Eval Menv
 171 evalModule globalEnv (Module mn tdefs vdefgs) =
 172   do (e_venv,l_venv) <- foldM evalVdef (eempty,eempty) vdefgs
 173      return (eextend globalEnv (mn,e_venv))
 174   where
 175     evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
 176     evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),t,e))) =
 177      do p <- hallocateE (suspendExp l_env e)
 178         let heaps =
 179                if m == "" then
 180                  (e_env,eextend l_env (x,Vheap p))
 181                else
 182                  (eextend e_env (x,Vheap p),l_env)
 183         return heaps
 184     evalVdef (e_env,l_env) (Rec vdefs) =
 185       do l_vs0 <- mapM preallocate l_xs
 186          let l_env' = foldl eextend l_env (zip l_xs l_vs0)
 187          let l_hs = map (suspendExp l_env') l_es
 188          mapM_ reallocate (zip l_vs0 l_hs)
 189          let e_hs = map (suspendExp l_env') e_es
 190          e_vs <- mapM allocate e_hs
 191          let e_env' = foldl eextend e_env (zip e_xs e_vs)
 192          return (e_env',l_env')
 193       where
 194          (l_xs,l_es) = unzip [(x,e) | Vdef(("",x),_,e) <- vdefs]
 195          (e_xs,e_es) = unzip [(x,e) | Vdef((m,x),_,e) <- vdefs, m /= ""]
 196          preallocate _ =
 197            do p <- hallocateE undefined
 198               return (Vheap p)
 199          reallocate (Vheap p0,h) =
 200            hupdateE p0 h
 201          allocate h =
 202            do p <- hallocateE h
 203               return (Vheap p)
 204
 205     suspendExp:: Venv -> Exp -> HeapValue
 206     suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
 207        where env' = thin env (delete x (freevarsExp e))
 208     suspendExp env e = Hthunk env' e
 209        where env' = thin env (freevarsExp e)
 210
 211
 212 evalExp :: Menv -> Venv -> Exp -> Eval Value
 213 evalExp globalEnv env (Var qv) =
 214   let v = qlookup globalEnv env qv
 215   in case v of
 216        Vheap p ->
 217           do z <- hlookupE p                                  -- can fail due to black-holing
 218              case z of
 219                Hthunk env' e ->
 220                  do hremoveE p                                -- black-hole
 221                     w@(Vheap p') <- evalExp globalEnv env' e  -- result is guaranteed to be boxed!
 222                     h <- hlookupE p'
 223                     hupdateE p h
 224                     return w
 225                _ -> return v                 -- return pointer to Hclos or Hconstr
 226        _ -> return v                         -- return Vimm or Vutuple
 227 evalExp globalEnv env (Lit l) = return (Vimm (evalLit l))
 228 evalExp globalEnv env (Dcon (_,c)) =
 229   do p <- hallocateE (Hconstr c [])
 230      return (Vheap p)
 231
 232 evalExp globalEnv env (App e1 e2) = evalApp env e1 [e2]
 233   where
 234     evalApp :: Venv -> Exp -> [Exp] -> Eval Value
 235     evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
 236     evalApp env (op @(Dcon (qdc@(m,c)))) es =
 237       do vs <- suspendExps globalEnv env es
 238          if isUtupleDc qdc then
 239            return (Vutuple vs)
 240           else
 241             {- allocate a thunk -}
 242             do p <- hallocateE (Hconstr c vs)
 243                return (Vheap p)
 244     evalApp env (op @ (Var(m,p))) es | m == primMname =
 245       do vs <- evalExps globalEnv env es
 246          case (p,vs) of
 247            ("raisezh",[exn]) -> raiseE exn
 248            ("catchzh",[body,handler,rws]) ->
 249               catchE (apply body [rws])
 250                      (\exn -> apply handler [exn,rws])
 251            _ -> evalPrimop p vs
 252     evalApp env (External s _) es =
 253       do vs <- evalExps globalEnv env es
 254          evalExternal s vs
 255     evalApp env (Appt e _) es = evalApp env e es
 256     evalApp env (Lam (Tb _) e) es = evalApp env e es
 257     evalApp env (Coerce _ e) es = evalApp env e es
 258     evalApp env (Note _ e) es = evalApp env e es
 259     evalApp env e es =
 260       {- e must now evaluate to a closure -}
 261       do vs <- suspendExps globalEnv env es
 262          vop <- evalExp globalEnv env e
 263          apply vop vs
 264
 265     apply :: Value -> [Value] -> Eval Value
 266     apply vop [] = return vop
 267     apply (Vheap p) (v:vs) =
 268       do Hclos env' x b <- hlookupE p
 269          v' <- evalExp globalEnv (eextend env' (x,v)) b
 270          apply v' vs
 271
 272
 273 evalExp globalEnv env (Appt e _) = evalExp globalEnv env e
 274 evalExp globalEnv env (Lam (Vb(x,_)) e) =
 275   do p <- hallocateE (Hclos env' x e)
 276      return (Vheap p)
 277   where env' = thin env (delete x (freevarsExp e))
 278 evalExp globalEnv env (Lam _ e) = evalExp globalEnv env e
 279 evalExp globalEnv env (Let vdef e) =
 280   do env' <- evalVdef globalEnv env vdef
 281      evalExp globalEnv env' e
 282   where
 283     evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
 284     evalVdef globalEnv env (Nonrec(Vdef((m,x),t,e))) =
 285       do v <- suspendExp globalEnv env e
 286          return (eextend env (x,v))
 287     evalVdef globalEnv env (Rec vdefs) =
 288       do vs0 <- mapM preallocate xs
 289          let env' = foldl eextend env (zip xs vs0)
 290          vs <- suspendExps globalEnv env' es
 291          mapM_ reallocate (zip vs0 vs)
 292          return env'
 293       where
 294         (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
 295         preallocate _ =
 296           do p <- hallocateE (Hconstr "UGH" [])
 297              return (Vheap p)
 298         reallocate (Vheap p0,Vheap p) =
 299           do h <- hlookupE p
 300              hupdateE p0 h
 301
 302 evalExp globalEnv env (Case e (x,_) alts) =
 303   do z <- evalExp globalEnv env e
 304      let env' = eextend env (x,z)
 305      case z of
 306        Vheap p ->
 307          do h <- hlookupE p   -- can fail due to black-holing
 308             case h of
 309               Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
 310               _ -> evalDefaultAlt env' alts
 311        Vutuple vs ->
 312          evalUtupleAlt env' vs (reverse alts)
 313        Vimm pv ->
 314          evalLitAlt env' pv (reverse alts)
 315   where
 316     evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
 317     evalDcAlt env dcon vs alts =
 318       f alts
 319       where
 320         f ((Acon (_,dcon') _ xs e):as) =
 321           if dcon == dcon' then
 322             evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
 323           else f as
 324         f [Adefault e] =
 325           evalExp globalEnv env e
 326         f _ = error "impossible Case-evalDcAlt"
 327
 328     evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
 329     evalUtupleAlt env vs [Acon _ _ xs e] =
 330        evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
 331
 332     evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
 333     evalLitAlt env pv alts =
 334       f alts
 335       where
 336         f ((Alit lit e):as) =
 337           let pv' = evalLit lit
 338           in if pv == pv' then
 339                evalExp globalEnv env e
 340              else f as
 341         f [Adefault e] =
 342           evalExp globalEnv env e
 343         f _ = error "impossible Case-evalLitAlt"
 344
 345     evalDefaultAlt :: Venv -> [Alt] -> Eval Value
 346     evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
 347
 348 evalExp globalEnv env (Coerce _ e) = evalExp globalEnv env e
 349 evalExp globalEnv env (Note _ e) = evalExp globalEnv env e
 350 evalExp globalEnv env (External s t) = evalExternal s []
 351
 352 evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
 353 evalExps globalEnv env = mapM (evalExp globalEnv env)
 354
 355 suspendExp:: Menv -> Venv -> Exp -> Eval Value
 356 suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
 357 suspendExp globalEnv env (Lit l) = return (Vimm (evalLit l))
 358 suspendExp globalEnv env (Lam (Vb(x,_)) e) =
 359    do p <- hallocateE (Hclos env' x e)
 360       return (Vheap p)
 361    where env' = thin env (delete x (freevarsExp e))
 362 suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
 363 suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
 364 suspendExp globalEnv env (Coerce _ e) = suspendExp globalEnv env e
 365 suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
 366 suspendExp globalEnv env (External s _) = evalExternal s []
 367 suspendExp globalEnv env e =
 368    do p <- hallocateE (Hthunk env' e)
 369       return (Vheap p)
 370    where env' = thin env (freevarsExp e)
 371
 372 suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
 373 suspendExps globalEnv env = mapM (suspendExp globalEnv env)
 374
 375 mlookup :: Menv -> Venv -> Mname -> Venv
 376 mlookup _          env       "" = env
 377 mlookup globalEnv  _         m  =
 378     case elookup globalEnv m of
 379       Just env' -> env'
 380       Nothing -> error ("undefined module name: " ++ m)
 381
 382 qlookup :: Menv -> Venv -> (Mname,Var) -> Value
 383 qlookup globalEnv env (m,k) =
 384   case elookup (mlookup globalEnv env m) k of
 385     Just v -> v
 386     Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
 387
 388 evalPrimop :: Var -> [Value] -> Eval Value
 389 evalPrimop "zpzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1+i2)))
 390 evalPrimop "zmzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1-i2)))
 391 evalPrimop "ztzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1*i2)))
 392 evalPrimop "zgzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = mkBool (i1 > i2)
 393 evalPrimop "remIntzh" [Vimm (PIntzh i1),Vimm (PIntzh i2)] = return (Vimm (PIntzh (i1 `rem` i2)))
 394 -- etc.
 395 evalPrimop p vs = error ("undefined primop: " ++ p)
 396
 397 evalExternal :: String -> [Value] -> Eval Value
 398 -- etc.
 399 evalExternal s vs = error "evalExternal undefined for now"  -- etc.,etc.
 400
 401 evalLit :: Lit -> PrimValue
 402 evalLit l =
 403     case l of
 404       Lint i (Tcon(_,"Intzh")) -> PIntzh i
 405       Lint i (Tcon(_,"Wordzh")) -> PWordzh i
 406       Lint i (Tcon(_,"Addrzh")) -> PAddrzh i
 407       Lint i (Tcon(_,"Charzh")) -> PCharzh i
 408       Lrational r (Tcon(_,"Floatzh")) -> PFloatzh r
 409       Lrational r (Tcon(_,"Doublezh")) -> PDoublezh r
 410       Lchar c (Tcon(_,"Charzh")) -> PCharzh (toEnum (ord c))
 411       Lstring s (Tcon(_,"Addrzh")) -> PAddrzh 0  -- should really be address of non-heap copy of C-format string s
 412
 413 {- Utilities -}
 414
 415 mkBool True =
 416   do p <- hallocateE (Hconstr "ZdwTrue" [])
 417      return (Vheap p)
 418 mkBool False =
 419   do p <- hallocateE (Hconstr "ZdwFalse" [])
 420      return (Vheap p)
 421
 422 thin env vars = efilter env (`elem` vars)
 423
 424 {- Return the free non-external variables in an expression. -}
 425
 426 freevarsExp :: Exp -> [Var]
 427 freevarsExp (Var ("",v)) = [v]
 428 freevarsExp (Var qv) = []
 429 freevarsExp (Dcon _) = []
 430 freevarsExp (Lit _) = []
 431 freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
 432 freevarsExp (Appt e t) = freevarsExp e
 433 freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
 434 freevarsExp (Lam _ e) = freevarsExp e
 435 freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
 436   where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
 437             where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
 438         freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
 439 freevarsExp (Case e (v,_) as) = freevarsExp e `union` [v] `union` freevarsAlts as
 440   where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
 441         freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
 442         freevarsAlt (Alit _ e) = freevarsExp e
 443         freevarsAlt (Adefault e) = freevarsExp e
 444 freevarsExp (Coerce _ e) = freevarsExp e
 445 freevarsExp (Note _ e) =  freevarsExp e
 446 freevarsExp (External _ _) = []
 447
 448
 449
 450