utils/ext-core/Interp.hs

   1 {-# OPTIONS -Wall -fno-warn-name-shadowing -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 ( evalProgram ) where
  19
  20 import Control.Monad.Error
  21 import Control.Monad.State
  22 import Data.Char
  23 import Data.List
  24
  25 import GHC.Exts hiding (Ptr)
  26 import System.IO
  27
  28 import Core
  29 import Env
  30 import Printer()
  31
  32 data HeapValue =
  33     Hconstr Dcon [Value]       -- constructed value (note: no qualifier needed!)
  34   | Hclos Venv Var Exp         -- function closure
  35   | Hthunk Venv Exp            -- unevaluated thunk
  36   deriving (Show)
  37
  38 type Ptr = Int
  39
  40 data Value =
  41     Vheap Ptr                  -- heap pointer (boxed)
  42   | Vimm PrimValue             -- immediate primitive value (unboxed)
  43   | Vutuple [Value]            -- unboxed tuples
  44   deriving (Show)
  45
  46 instance Error Value where
  47   -- TODO: ??
  48   strMsg s = error s
  49
  50 type Venv = Env Var Value       -- values of vars
  51
  52 data PrimValue =                -- values of the (unboxed) primitive types
  53     PCharzh Integer             -- actually 31-bit unsigned
  54   | PIntzh Integer              -- actually WORD_SIZE_IN_BITS-bit signed
  55   | PWordzh Integer             -- actually WORD_SIZE_IN_BITS-bit unsigned
  56   | PAddrzh Integer             -- actually native pointer size
  57   | PFloatzh Rational           -- actually 32-bit
  58   | PDoublezh Rational          -- actually 64-bit
  59 --  etc., etc.
  60   | PString String
  61   deriving (Eq,Show)
  62
  63 type Menv = Env AnMname Venv    -- modules
  64
  65 initialGlobalEnv :: Menv
  66 initialGlobalEnv =
  67     efromlist
  68         [(primMname,efromlist [("realWorldzh",Vimm (PIntzh 0))])]
  69
  70 {- Heap management. -}
  71 {- Nothing is said about garbage collection. -}
  72
  73 data Heap = Heap Ptr (Env Ptr HeapValue)
  74     -- last cell allocated; environment of allocated cells
  75   deriving Show
  76
  77 hallocate :: Heap -> HeapValue -> (Heap,Ptr)
  78 hallocate (Heap last contents) v =
  79    let next = last+1
  80    in (Heap next (eextend contents (next,v)),next)
  81
  82 hupdate :: Heap -> Ptr -> HeapValue -> Heap
  83 hupdate (Heap last contents) p v =
  84    Heap last (eextend contents (p,v))
  85
  86 hlookup:: Heap -> Ptr -> HeapValue
  87 hlookup (Heap _ contents) p =
  88    case elookup contents p of
  89      Just v -> v
  90      Nothing -> error "Missing heap entry (black hole?)"
  91
  92 hremove :: Heap -> Ptr -> Heap
  93 hremove (Heap last contents) p =
  94    Heap last (eremove contents p)
  95
  96 hempty :: Heap
  97 hempty = Heap 0 eempty
  98
  99 {- The evaluation monad manages the heap and the possiblity
 100    of exceptions. -}
 101
 102 type Exn = Value
 103
 104 type Eval a = ErrorT Exn (StateT Heap IO) a
 105
 106 hallocateE :: HeapValue -> Eval Ptr
 107 hallocateE v = do
 108   h <- get
 109   let (h', p) = hallocate h v
 110   put h'
 111   return p
 112
 113 hupdateE :: Ptr -> HeapValue -> Eval ()
 114 hupdateE p v = modify (\ h -> hupdate h p v)
 115
 116 hlookupE :: Ptr -> Eval HeapValue
 117 hlookupE p =  get >>= (\h -> return (hlookup h p))
 118
 119 hremoveE :: Ptr -> Eval ()
 120 hremoveE p = modify (\h -> hremove h p)
 121
 122 raiseE :: Exn -> Eval a
 123 raiseE = throwError
 124
 125 catchE :: Show a => Eval a -> (Exn -> Eval a) -> Eval a
 126 catchE = catchError
 127
 128 runE :: Eval a -> IO a
 129 runE m = do
 130   resultOrError <- evalStateT (runErrorT m) hempty
 131   case resultOrError of
 132     Right v -> return v
 133     Left exn -> error
 134       ("evaluation failed with uncaught exception: " ++ show exn)
 135
 136 {- Main entry point -}
 137 -- TODO: This is in the IO monad because primitive I/O ops
 138 -- actually perform the IO. It might be better to model it
 139 -- instead (by having the interpreter return a ([Char] -> (Value, [Char])))
 140 evalProgram :: [Module] -> IO Value
 141 evalProgram modules = runE $ do
 142      -- We do two passes: one to slurp in all the definitions *except*
 143      -- for :Main.main, and then one to look for the Main module
 144      -- and extract out just the :Main.main defn.
 145      -- It's kind of annoying.
 146      globalEnv' <- foldM evalModule initialGlobalEnv modules
 147      globalEnv  <- evalModule globalEnv' (rootModule modules)
 148      Vutuple [_,v] <- evalExp globalEnv eempty (App (Var wrapperMainVar)
 149                        stateToken)
 150      return v
 151
 152 rootModule :: [Module] -> Module
 153 -- This looks for the Main module, and constructs
 154 -- a fake module containing only the defn of
 155 -- :Main.main.
 156 rootModule ms =
 157   case find (\ (Module mn _ _) -> mn == mainMname) ms of
 158     Just (Module _ _ [Rec bs]) ->
 159         Module wrapperMainMname []
 160           [Rec (filter isWrapperMainVdef bs)]
 161     _ -> error "eval: missing main module"
 162   where isWrapperMainVdef (Vdef (v,_,_)) | v == wrapperMainVar = True
 163         isWrapperMainVdef _ = False
 164
 165 {- Environments:
 166
 167 Evaluating a module just fills an environment with suspensions for all
 168 the external top-level values; it doesn't actually do any evaluation
 169 or look anything up.
 170
 171 By the time we actually evaluate an expression, all external values from
 172 all modules will be in globalEnv.  So evaluation just maintains an environment
 173 of non-external values (top-level or local).  In particular, only non-external
 174 values end up in closures (all other values are accessible from globalEnv.)
 175
 176 Throughout:
 177
 178 - globalEnv contains external values (all top-level) from all modules seen so far.
 179
 180 In evalModule:
 181
 182 - e_venv    contains external values (all top-level) seen so far in current module
 183 - l_venv    contains non-external values (top-level or local)
 184                  seen so far in current module.
 185 In evalExp:
 186
 187 - env       contains non-external values (top-level or local) seen so far
 188                 in current expression.
 189 -}
 190
 191
 192 evalModule :: Menv -> Module -> Eval Menv
 193 evalModule globalEnv (Module mn _ vdefgs) =
 194   do (e_venv,_) <- foldM evalVdef (eempty,eempty) vdefgs
 195      return (eextend globalEnv (mn,e_venv))
 196   where
 197     evalVdef :: (Venv,Venv) -> Vdefg -> Eval (Venv,Venv)
 198     evalVdef (e_env,l_env) (Nonrec(Vdef((m,x),_,e))) =
 199      do p <- hallocateE (suspendExp l_env e)
 200         let heaps =
 201                case m of
 202                  Nothing -> (e_env,eextend l_env (x,Vheap p))
 203                  _       -> (eextend e_env (x,Vheap p),l_env)
 204         return heaps
 205     evalVdef (e_env,l_env) (Rec vdefs) =
 206       do l_vs0 <- mapM preallocate l_xs
 207          let l_env' = foldl eextend l_env (zip l_xs (map Vheap l_vs0))
 208          let l_hs = map (suspendExp l_env') l_es
 209          mapM_ reallocate (zip l_vs0 l_hs)
 210          let e_hs = map (suspendExp l_env') e_es
 211          e_vs <- (liftM (map Vheap)) $ mapM allocate e_hs
 212          let e_env' = foldl eextend e_env (zip e_xs e_vs)
 213          return (e_env',l_env')
 214       where
 215          (l_xs,l_es) = unzip [(x,e) | Vdef((Nothing,x),_,e) <- vdefs]
 216          (e_xs,e_es) = unzip [(x,e) | Vdef ((Just _,x),_,e) <-
 217                          -- Do not dump the defn for :Main.main into
 218                          -- the environment for Main!
 219                                        filter inHomeModule vdefs]
 220          inHomeModule (Vdef ((Just m,_),_,_)) | m == mn = True
 221          inHomeModule _ = False
 222          preallocate _ =
 223            do p <- hallocateE undefined
 224               return p
 225          reallocate (p0,h) =
 226            hupdateE p0 h
 227          allocate h =
 228            do p <- hallocateE h
 229               return p
 230
 231     suspendExp:: Venv -> Exp -> HeapValue
 232     suspendExp env (Lam (Vb(x,_)) e) = Hclos env' x e
 233        where env' = thin env (delete x (freevarsExp e))
 234     suspendExp env e = Hthunk env' e
 235        where env' = thin env (freevarsExp e)
 236
 237 evalExp :: Menv -> Venv -> Exp -> Eval Value
 238 evalExp globalEnv env = eval
 239   where eval (Var qv) =
 240           let v = qlookup globalEnv env qv
 241           in case v of
 242                Vheap p -> do
 243                  z <- hlookupE p                    -- can fail due to black-holing
 244                  case z of
 245                    Hthunk env' e -> do
 246                      hremoveE p                     -- black-hole
 247                      w <- evalExp globalEnv env' e  -- result is guaranteed to be boxed!
 248                      case w of
 249                        Vheap p' -> do
 250                          h <- hlookupE p'
 251                          hupdateE p h
 252                          return w
 253                        _ -> error ("eval: w was not boxed: " ++ show w)
 254                    _ -> return v -- return pointer to Hclos or Hconstr
 255                _ -> return v     -- return Vimm or Vutuple
 256         eval (Lit l) = return (Vimm (evalLit l))
 257         eval (Dcon (_,c)) = do
 258            p <- hallocateE (Hconstr c [])
 259            return (Vheap p)
 260         eval (App e1 e2) =
 261           evalApp env e1 [e2]
 262             where
 263               evalApp :: Venv -> Exp -> [Exp] -> Eval Value
 264               evalApp env (App e1 e2) es = evalApp env e1 (e2:es)
 265               evalApp env (Dcon (qdc@(_,c))) es =
 266                   do vs <- suspendExps globalEnv env es
 267                      if isUtupleDc qdc
 268                        then
 269                          return (Vutuple vs)
 270                        else
 271                          {- allocate a thunk -}
 272                          do p <- hallocateE (Hconstr c vs)
 273                             return (Vheap p)
 274               evalApp env (Var(v@(_,p))) es | isPrimVar v =
 275                  do vs <- evalExps globalEnv env es
 276                     case (p,vs) of
 277                       ("raisezh",[exn]) -> raiseE exn
 278                       ("catchzh",[body,handler,rws]) ->
 279                                 catchE (apply body [rws])
 280                                 (\exn -> apply handler [exn,rws])
 281                       _ -> evalPrimop p vs
 282               evalApp env (External s _) es =
 283                   do vs <- evalExps globalEnv env es
 284                      evalExternal s vs
 285               evalApp env (Appt e _) es     = evalApp env e es
 286               evalApp env (Lam (Tb _) e) es = evalApp env e es
 287               evalApp env (Cast e _) es     = evalApp env e es
 288               evalApp env (Note _ e) es     = evalApp env e es
 289               evalApp env e es =
 290           {- e must now evaluate to a closure -}
 291                   do vs <- suspendExps globalEnv env es
 292                      vop <- evalExp globalEnv env e
 293                      apply vop vs
 294
 295               apply :: Value -> [Value] -> Eval Value
 296               apply vop [] = return vop
 297               apply (Vheap p) (v:vs) =
 298                   do Hclos env' x b <- hlookupE p
 299                      v' <- evalExp globalEnv (eextend env' (x,v)) b
 300                      apply v' vs
 301               apply _ _ = error ("apply: operator is not a closure")
 302
 303         eval (Appt e _) = evalExp globalEnv env e
 304         eval (Lam (Vb(x,_)) e) = do
 305            p <- hallocateE (Hclos env' x e)
 306            return (Vheap p)
 307                where env' = thin env (delete x (freevarsExp e))
 308         eval (Lam _ e) = evalExp globalEnv env e
 309         eval (Let vdef e) =
 310           do env' <- evalVdef globalEnv env vdef
 311              evalExp globalEnv env' e
 312             where
 313               evalVdef :: Menv -> Venv -> Vdefg -> Eval Venv
 314               evalVdef globalEnv env (Nonrec(Vdef((_,x),_,e))) =
 315                   do v <- suspendExp globalEnv env e
 316                      return (eextend env (x,v))
 317               evalVdef globalEnv env (Rec vdefs) =
 318                   do vs0 <- mapM preallocate xs
 319                      let env' = foldl eextend env (zip xs (map Vheap vs0))
 320                      vs <- suspendExps globalEnv env' es
 321                      mapM_ reallocate (zip vs0 vs)
 322                      return env'
 323                   where
 324                     (xs,es) = unzip [(x,e) | Vdef((_,x),_,e) <- vdefs]
 325                     preallocate _ =
 326                         do p <- hallocateE (Hconstr "UGH" [])
 327                            return p
 328                     reallocate (p0,Vheap p) =
 329                         do h <- hlookupE p
 330                            hupdateE p0 h
 331                     reallocate (_,_) = error "reallocate: expected a heap value"
 332         eval (Case e (x,_) _ alts) =
 333             do z <- evalExp globalEnv env e
 334                let env' = eextend env (x,z)
 335                case z of
 336                  Vheap p -> do
 337                    h <- hlookupE p   -- can fail due to black-holing
 338                    case h of
 339                      Hconstr dcon vs -> evalDcAlt env' dcon vs (reverse alts)
 340                      _ ->               evalDefaultAlt env' alts
 341                  Vutuple vs ->
 342                      evalUtupleAlt env' vs (reverse alts)
 343                  Vimm pv ->
 344                      evalLitAlt env' pv (reverse alts)
 345             where
 346               evalDcAlt :: Venv -> Dcon -> [Value] -> [Alt] -> Eval Value
 347               evalDcAlt env dcon vs = f
 348                 where
 349                   f ((Acon (_,dcon') _ xs e):as) =
 350                      if dcon == dcon' then
 351                        evalExp globalEnv
 352                          (foldl eextend env (zip (map fst xs) vs)) e
 353                      else f as
 354                   f [Adefault e] =
 355                     evalExp globalEnv env e
 356                   f _ = error $ "impossible Case-evalDcAlt"
 357
 358               evalUtupleAlt :: Venv -> [Value] -> [Alt] -> Eval Value
 359               evalUtupleAlt env vs [Acon _ _ xs e] =
 360                   evalExp globalEnv (foldl eextend env (zip (map fst xs) vs)) e
 361               evalUtupleAlt _ _ _ = error ("impossible Case: evalUtupleAlt")
 362
 363               evalLitAlt :: Venv -> PrimValue -> [Alt] -> Eval Value
 364               evalLitAlt env pv alts =
 365                   f alts
 366                       where
 367                         f ((Alit lit e):as) =
 368                             let pv' = evalLit lit
 369                             in if pv == pv' then
 370                                    evalExp globalEnv env e
 371                                else f as
 372                         f [Adefault e] =
 373                             evalExp globalEnv env e
 374                         f _ = error "impossible Case-evalLitAlt"
 375
 376               evalDefaultAlt :: Venv -> [Alt] -> Eval Value
 377               evalDefaultAlt env [Adefault e] = evalExp globalEnv env e
 378               evalDefaultAlt _ _ = error "evalDefaultAlt: impossible case"
 379
 380         eval (Cast e _) = evalExp globalEnv env e
 381         eval (Note _ e) = evalExp globalEnv env e
 382         eval (External s _) = evalExternal s []
 383
 384 evalExps :: Menv -> Venv -> [Exp] -> Eval [Value]
 385 evalExps globalEnv env = mapM (evalExp globalEnv env)
 386
 387 suspendExp:: Menv -> Venv -> Exp -> Eval Value
 388 suspendExp globalEnv env (Var qv) = return (qlookup globalEnv env qv)
 389 suspendExp _ _ (Lit l) = return (Vimm (evalLit l))
 390 suspendExp _ env (Lam (Vb(x,_)) e) =
 391    do p <- hallocateE (Hclos env' x e)
 392       return (Vheap p)
 393    where env' = thin env (delete x (freevarsExp e))
 394 suspendExp globalEnv env (Lam _ e) = suspendExp globalEnv env e
 395 suspendExp globalEnv env (Appt e _) = suspendExp globalEnv env e
 396 suspendExp globalEnv env (Cast e _) = suspendExp globalEnv env e
 397 suspendExp globalEnv env (Note _ e) = suspendExp globalEnv env e
 398 suspendExp _ _ (External s _) = evalExternal s []
 399 suspendExp _ env e =
 400    do p <- hallocateE (Hthunk env' e)
 401       return (Vheap p)
 402    where env' = thin env (freevarsExp e)
 403
 404 suspendExps :: Menv -> Venv -> [Exp] -> Eval [Value]
 405 suspendExps globalEnv env = mapM (suspendExp globalEnv env)
 406
 407 mlookup :: Menv -> Venv -> Mname -> Venv
 408 mlookup _          env       Nothing  = env
 409 mlookup globalEnv  _         (Just m) =
 410     case elookup globalEnv m of
 411       Just env' -> env'
 412       Nothing -> error ("Interp: undefined module name: " ++ show m)
 413
 414 qlookup :: Menv -> Venv -> (Mname,Var) -> Value
 415 qlookup globalEnv env (m,k) =
 416   case elookup (mlookup globalEnv env m) k of
 417     Just v -> v
 418     Nothing -> error ("undefined identifier: " ++ show m ++ "." ++ show k)
 419
 420 evalPrimop :: Var -> [Value] -> Eval Value
 421 evalPrimop "zpzh"        = primIntBinop    (+)
 422 evalPrimop "zpzhzh"      = primDoubleBinop (+)
 423 evalPrimop "zmzh"        = primIntBinop    (-)
 424 evalPrimop "zmzhzh"      = primDoubleBinop (-)
 425 evalPrimop "ztzh"        = primIntBinop    (*)
 426 evalPrimop "ztzhzh"      = primDoubleBinop (*)
 427 evalPrimop "zgzh"        = primIntCmpOp    (>)
 428 evalPrimop "zlzh"        = primIntCmpOp    (<)
 429 evalPrimop "zlzhzh"      = primDoubleCmpOp (<)
 430 evalPrimop "zezezh"      = primIntCmpOp    (==)
 431 evalPrimop "zlzezh"      = primIntCmpOp    (<=)
 432 evalPrimop "zlzezhzh"    = primDoubleCmpOp (<=)
 433 evalPrimop "zgzezh"      = primIntCmpOp    (>=)
 434 evalPrimop "zszezh"      = primIntCmpOp    (/=)
 435 evalPrimop "zszhzh"      = primDoubleCmpOp (/=)
 436 evalPrimop "negateIntzh" = primIntUnop     (\ i -> -i)
 437 evalPrimop "quotIntzh"   = primIntBinop    quot
 438 evalPrimop "remIntzh"    = primIntBinop    rem
 439 evalPrimop "subIntCzh"   = primSubIntC
 440 evalPrimop "mulIntMayOflozh" = primIntBinop
 441   (\ i j ->
 442      case (fromIntegral i, fromIntegral j) of
 443        (I# x, I# y) ->
 444          case x `mulIntMayOflo#` y of
 445            k -> fromIntegral (I# k))
 446 evalPrimop "narrow32Intzh" = primIntUnop
 447   (\ i ->
 448      case fromIntegral i of
 449        (I# j) -> case narrow32Int# j of
 450                    k -> fromIntegral (I# k))
 451 evalPrimop "int2Doublezh" = primInt2Double
 452 -- single-threaded, so, it's a no-op
 453 --evalPrimop "noDuplicatezh" [state] = return state
 454 evalPrimop "indexCharOffAddrzh" = primIndexChar
 455 evalPrimop "eqCharzh"           = primCharCmpOp (==)
 456 evalPrimop "leCharzh"           = primCharCmpOp (<)
 457 evalPrimop "ordzh"              = primOrd
 458 evalPrimop "chrzh"              = primChr
 459 evalPrimop "isSpacezh"          = primCharUnop isSpace
 460 evalPrimop "isAlphazh"          = primCharUnop isAlpha
 461 evalPrimop "hPutCharzh"         = primHPutChar
 462 -- etc.
 463 evalPrimop p = error ("undefined primop: " ++ p)
 464
 465 primIntUnop :: (Integer -> Integer) -> [Value] -> Eval Value
 466 primIntUnop op [Vimm (PIntzh i)] = return (Vimm (PIntzh (op i)))
 467 primIntUnop _ _ = error "primIntUnop: wrong number of arguments"
 468
 469 primIntBinop :: (Integer -> Integer -> Integer) -> [Value] -> Eval Value
 470 primIntBinop op [Vimm (PIntzh i), Vimm (PIntzh j)] =
 471   return (Vimm (PIntzh (i `op` j)))
 472 primIntBinop _ _ = error "primIntBinop: wrong number of arguments"
 473
 474 primDoubleBinop :: (Rational -> Rational -> Rational) -> [Value] -> Eval Value
 475 primDoubleBinop op [Vimm (PDoublezh i), Vimm (PDoublezh j)] =
 476   return (Vimm (PDoublezh (i `op` j)))
 477 primDoubleBinop _ _ = error "primDoubleBinop: wrong number of arguments"
 478
 479 primIntCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
 480 primIntCmpOp op [Vimm (PIntzh i), Vimm (PIntzh j)] = mkBool (i `op` j)
 481 primIntCmpOp _ _ = error "primIntCmpOp: wrong number of arguments"
 482
 483 primDoubleCmpOp :: (Rational -> Rational -> Bool) -> [Value] -> Eval Value
 484 primDoubleCmpOp op [Vimm (PDoublezh i), Vimm (PDoublezh j)] = mkBool (i `op` j)
 485 primDoubleCmpOp _ _ = error "primDoubleCmpOp: wrong number of arguments"
 486
 487 primCharCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
 488 primCharCmpOp op [Vimm (PCharzh c), Vimm (PCharzh d)] = mkBool (c `op` d)
 489 primCharCmpOp _ _ = error "primCharCmpOp: wrong number of arguments"
 490
 491 primSubIntC :: [Value] -> Eval Value
 492 primSubIntC [Vimm (PIntzh i1), Vimm (PIntzh i2)] =
 493   case (fromIntegral i1, fromIntegral i2) of
 494     (I# int1, I# int2) ->
 495        case (int1 `subIntC#` int2) of
 496         (# res1, res2 #) ->
 497            return $ Vutuple [Vimm (PIntzh (fromIntegral (I# res1))),
 498                              Vimm (PIntzh (fromIntegral (I# res2)))]
 499 primSubIntC _ = error "primSubIntC: wrong number of arguments"
 500
 501 primInt2Double :: [Value] -> Eval Value
 502 primInt2Double [Vimm (PIntzh i)] =
 503   return (Vimm (PDoublezh (fromIntegral i)))
 504 primInt2Double _ = error "primInt2Double: wrong number of arguments"
 505
 506 primOrd :: [Value] -> Eval Value
 507 primOrd [Vimm (PCharzh c)] = return $ Vimm (PIntzh c)
 508 primOrd _ = error "primOrd: wrong number of arguments"
 509
 510 primChr :: [Value] -> Eval Value
 511 primChr [Vimm (PIntzh c)] = return $ Vimm (PCharzh c)
 512 primChr _ = error "primChr: wrong number of arguments"
 513
 514 primCharUnop :: (Char -> Bool) -> [Value] -> Eval Value
 515 primCharUnop op [Vimm (PCharzh c)] = mkBool (op (chr (fromIntegral c)))
 516 primCharUnop _ _ = error "primCharUnop: wrong number of arguments"
 517
 518 primIndexChar :: [Value] -> Eval Value
 519 primIndexChar [(Vimm (PString s)), (Vimm (PIntzh i))] =
 520   -- String is supposed to be null-terminated, so if i == length(s),
 521   -- we return null. (If i > length(s), emit nasal demons.)
 522   return $ let len = fromIntegral $ length s in
 523              if i < len
 524                then Vimm (PCharzh (fromIntegral (ord (s !! fromIntegral i))))
 525                else if i == len
 526                       then Vimm (PCharzh 0)
 527                       else error "indexCharOffAddr#: index too large"
 528 primIndexChar _ = error "primIndexChar: wrong number of arguments"
 529
 530 primHPutChar :: [Value] -> Eval Value
 531 primHPutChar [Vimm (PIntzh hdl), Vimm (PCharzh c)] =
 532   liftIO (hPutChar
 533      (if hdl == 0
 534         then stdin
 535         else if hdl == 1
 536                then stdout
 537                else -- lol
 538                  stderr) (chr (fromIntegral c))) >>
 539   returnUnit
 540 primHPutChar _ = error "primHPutChar: wrong number of arguments"
 541
 542 evalExternal :: String -> [Value] -> Eval Value
 543 -- etc.
 544 evalExternal s _ = error $ "evalExternal undefined for now: " ++ show s  -- etc.,etc.
 545
 546 returnUnit :: Eval Value
 547 returnUnit = do
 548   p <- hallocateE (Hclos eempty "_"
 549          (App (App (Dcon (dcUtuple 2)) stateToken) unitCon))
 550   return $ Vheap p
 551
 552 evalLit :: Lit -> PrimValue
 553 evalLit (Literal l t) =
 554     case l of
 555       Lint i | (Tcon(_,"Intzh")) <- t -> PIntzh i
 556       Lint i | (Tcon(_,"Wordzh")) <- t -> PWordzh i
 557       Lint i | (Tcon(_,"Addrzh")) <- t -> PAddrzh i
 558       Lint i | (Tcon(_,"Charzh"))<- t -> PCharzh i
 559       Lrational r | (Tcon(_,"Floatzh"))  <- t -> PFloatzh r
 560       Lrational r | (Tcon(_,"Doublezh")) <- t -> PDoublezh r
 561       Lchar c | (Tcon(_,"Charzh")) <- t       -> PCharzh (toEnum (ord c))
 562       Lstring s | (Tcon(_,"Addrzh")) <- t     -> PString s
 563           -- should really be address of non-heap copy of C-format string s
 564           -- tjc: I am ignoring this comment
 565       _ -> error ("evalLit: strange combination of literal "
 566              ++ show l ++ " and type " ++ show t)
 567
 568 {- Utilities -}
 569
 570 mkBool :: Bool -> Eval Value
 571 mkBool True =
 572   do p <- hallocateE (Hconstr "True" [])
 573      return (Vheap p)
 574 mkBool False =
 575   do p <- hallocateE (Hconstr "False" [])
 576      return (Vheap p)
 577
 578 thin :: Ord a => Env a b -> [a] -> Env a b
 579 thin env vars = efilter env (`elem` vars)
 580
 581 {- Return the free non-external variables in an expression. -}
 582
 583 freevarsExp :: Exp -> [Var]
 584 freevarsExp (Var (Nothing,v)) = [v]
 585 freevarsExp (Var _) = []
 586 freevarsExp (Dcon _) = []
 587 freevarsExp (Lit _) = []
 588 freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
 589 freevarsExp (Appt e _) = freevarsExp e
 590 freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
 591 freevarsExp (Lam _ e) = freevarsExp e
 592 freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
 593   where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
 594             where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
 595         freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
 596 freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as
 597   where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
 598         freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
 599         freevarsAlt (Alit _ e) = freevarsExp e
 600         freevarsAlt (Adefault e) = freevarsExp e
 601 freevarsExp (Cast e _) = freevarsExp e
 602 freevarsExp (Note _ e) =  freevarsExp e
 603 freevarsExp (External _ _) = []
 604
 605 stateToken :: Exp
 606 stateToken = Var (qual primMname "realWorldzh")
 607
 608 unitCon :: Exp
 609 unitCon = Dcon (qual baseMname "Z0T")