utils/ext-core/Interp.hs

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