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