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 "addIntCzh"   = primAddIntC
 441 evalPrimop "mulIntMayOflozh" = primIntBinop
 442   (\ i j ->
 443      case (fromIntegral i, fromIntegral j) of
 444        (I# x, I# y) ->
 445          case x `mulIntMayOflo#` y of
 446            k -> fromIntegral (I# k))
 447 evalPrimop "narrow32Intzh" = primIntUnop
 448   (\ i ->
 449      case fromIntegral i of
 450        (I# j) -> case narrow32Int# j of
 451                    k -> fromIntegral (I# k))
 452 evalPrimop "int2Doublezh" = primInt2Double
 453 -- single-threaded, so, it's a no-op
 454 --evalPrimop "noDuplicatezh" [state] = return state
 455 evalPrimop "indexCharOffAddrzh" = primIndexChar
 456 evalPrimop "eqCharzh"           = primCharCmpOp (==)
 457 evalPrimop "leCharzh"           = primCharCmpOp (<)
 458 evalPrimop "ordzh"              = primOrd
 459 evalPrimop "chrzh"              = primChr
 460 evalPrimop "isSpacezh"          = primCharUnop isSpace
 461 evalPrimop "isAlphazh"          = primCharUnop isAlpha
 462 evalPrimop "hPutCharzh"         = primHPutChar
 463 -- etc.
 464 evalPrimop p = error ("undefined primop: " ++ p)
 465
 466 primIntUnop :: (Integer -> Integer) -> [Value] -> Eval Value
 467 primIntUnop op [Vimm (PIntzh i)] = return (Vimm (PIntzh (op i)))
 468 primIntUnop _ _ = error "primIntUnop: wrong number of arguments"
 469
 470 primIntBinop :: (Integer -> Integer -> Integer) -> [Value] -> Eval Value
 471 primIntBinop op [Vimm (PIntzh i), Vimm (PIntzh j)] =
 472   return (Vimm (PIntzh (i `op` j)))
 473 primIntBinop _ _ = error "primIntBinop: wrong number of arguments"
 474
 475 primDoubleBinop :: (Rational -> Rational -> Rational) -> [Value] -> Eval Value
 476 primDoubleBinop op [Vimm (PDoublezh i), Vimm (PDoublezh j)] =
 477   return (Vimm (PDoublezh (i `op` j)))
 478 primDoubleBinop _ _ = error "primDoubleBinop: wrong number of arguments"
 479
 480 primIntCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
 481 primIntCmpOp op [Vimm (PIntzh i), Vimm (PIntzh j)] = mkBool (i `op` j)
 482 primIntCmpOp _ _ = error "primIntCmpOp: wrong number of arguments"
 483
 484 primDoubleCmpOp :: (Rational -> Rational -> Bool) -> [Value] -> Eval Value
 485 primDoubleCmpOp op [Vimm (PDoublezh i), Vimm (PDoublezh j)] = mkBool (i `op` j)
 486 primDoubleCmpOp _ _ = error "primDoubleCmpOp: wrong number of arguments"
 487
 488 primCharCmpOp :: (Integer -> Integer -> Bool) -> [Value] -> Eval Value
 489 primCharCmpOp op [Vimm (PCharzh c), Vimm (PCharzh d)] = mkBool (c `op` d)
 490 primCharCmpOp _ _ = error "primCharCmpOp: wrong number of arguments"
 491
 492 primSubIntC :: [Value] -> Eval Value
 493 primSubIntC vs = carryOp subIntC# vs
 494
 495 primAddIntC :: [Value] -> Eval Value
 496 primAddIntC vs = carryOp addIntC# vs
 497
 498 carryOp :: (Int# -> Int# -> (# Int#, Int# #)) -> [Value] -> Eval Value
 499 carryOp op [Vimm (PIntzh i1), Vimm (PIntzh i2)] =
 500   case (fromIntegral i1, fromIntegral i2) of
 501     (I# int1, I# int2) ->
 502        case (int1 `op` int2) of
 503         (# res1, res2 #) ->
 504            return $ Vutuple [Vimm (PIntzh (fromIntegral (I# res1))),
 505                              Vimm (PIntzh (fromIntegral (I# res2)))]
 506 carryOp _ _ = error "carryOp: wrong number of arguments"
 507
 508 primInt2Double :: [Value] -> Eval Value
 509 primInt2Double [Vimm (PIntzh i)] =
 510   return (Vimm (PDoublezh (fromIntegral i)))
 511 primInt2Double _ = error "primInt2Double: wrong number of arguments"
 512
 513 primOrd :: [Value] -> Eval Value
 514 primOrd [Vimm (PCharzh c)] = return $ Vimm (PIntzh c)
 515 primOrd _ = error "primOrd: wrong number of arguments"
 516
 517 primChr :: [Value] -> Eval Value
 518 primChr [Vimm (PIntzh c)] = return $ Vimm (PCharzh c)
 519 primChr _ = error "primChr: wrong number of arguments"
 520
 521 primCharUnop :: (Char -> Bool) -> [Value] -> Eval Value
 522 primCharUnop op [Vimm (PCharzh c)] = mkBool (op (chr (fromIntegral c)))
 523 primCharUnop _ _ = error "primCharUnop: wrong number of arguments"
 524
 525 primIndexChar :: [Value] -> Eval Value
 526 primIndexChar [(Vimm (PString s)), (Vimm (PIntzh i))] =
 527   -- String is supposed to be null-terminated, so if i == length(s),
 528   -- we return null. (If i > length(s), emit nasal demons.)
 529   return $ let len = fromIntegral $ length s in
 530              if i < len
 531                then Vimm (PCharzh (fromIntegral (ord (s !! fromIntegral i))))
 532                else if i == len
 533                       then Vimm (PCharzh 0)
 534                       else error "indexCharOffAddr#: index too large"
 535 primIndexChar _ = error "primIndexChar: wrong number of arguments"
 536
 537 primHPutChar :: [Value] -> Eval Value
 538 primHPutChar [Vimm (PIntzh hdl), Vimm (PCharzh c)] =
 539   liftIO (hPutChar
 540      (if hdl == 0
 541         then stdin
 542         else if hdl == 1
 543                then stdout
 544                else -- lol
 545                  stderr) (chr (fromIntegral c))) >>
 546   returnUnit
 547 primHPutChar _ = error "primHPutChar: wrong number of arguments"
 548
 549 evalExternal :: String -> [Value] -> Eval Value
 550 -- etc.
 551 evalExternal s _ = error $ "evalExternal undefined for now: " ++ show s  -- etc.,etc.
 552
 553 returnUnit :: Eval Value
 554 returnUnit = do
 555   p <- hallocateE (Hclos eempty "_"
 556          (App (App (Dcon (dcUtuple 2)) stateToken) unitCon))
 557   return $ Vheap p
 558
 559 evalLit :: Lit -> PrimValue
 560 evalLit (Literal l t) =
 561     case l of
 562       Lint i | (Tcon(_,"Intzh")) <- t -> PIntzh i
 563       Lint i | (Tcon(_,"Wordzh")) <- t -> PWordzh i
 564       Lint i | (Tcon(_,"Addrzh")) <- t -> PAddrzh i
 565       Lint i | (Tcon(_,"Charzh"))<- t -> PCharzh i
 566       Lrational r | (Tcon(_,"Floatzh"))  <- t -> PFloatzh r
 567       Lrational r | (Tcon(_,"Doublezh")) <- t -> PDoublezh r
 568       Lchar c | (Tcon(_,"Charzh")) <- t       -> PCharzh (toEnum (ord c))
 569       Lstring s | (Tcon(_,"Addrzh")) <- t     -> PString s
 570           -- should really be address of non-heap copy of C-format string s
 571           -- tjc: I am ignoring this comment
 572       _ -> error ("evalLit: strange combination of literal "
 573              ++ show l ++ " and type " ++ show t)
 574
 575 {- Utilities -}
 576
 577 mkBool :: Bool -> Eval Value
 578 mkBool True =
 579   do p <- hallocateE (Hconstr "True" [])
 580      return (Vheap p)
 581 mkBool False =
 582   do p <- hallocateE (Hconstr "False" [])
 583      return (Vheap p)
 584
 585 thin :: Ord a => Env a b -> [a] -> Env a b
 586 thin env vars = efilter env (`elem` vars)
 587
 588 {- Return the free non-external variables in an expression. -}
 589
 590 freevarsExp :: Exp -> [Var]
 591 freevarsExp (Var (Nothing,v)) = [v]
 592 freevarsExp (Var _) = []
 593 freevarsExp (Dcon _) = []
 594 freevarsExp (Lit _) = []
 595 freevarsExp (App e1 e2) = freevarsExp e1 `union` freevarsExp e2
 596 freevarsExp (Appt e _) = freevarsExp e
 597 freevarsExp (Lam (Vb(v,_)) e) = delete v (freevarsExp e)
 598 freevarsExp (Lam _ e) = freevarsExp e
 599 freevarsExp (Let vdefg e) = freevarsVdefg vdefg `union` freevarsExp e
 600   where freevarsVdefg (Rec vdefs) = (foldl union [] (map freevarsExp es)) \\ vs
 601             where (vs,es) = unzip [(v,e) | Vdef((_,v),_,e) <- vdefs]
 602         freevarsVdefg (Nonrec (Vdef (_,_,e))) = freevarsExp e
 603 freevarsExp (Case e (v,_) _ as) = freevarsExp e `union` [v] `union` freevarsAlts as
 604   where freevarsAlts alts = foldl union [] (map freevarsAlt alts)
 605         freevarsAlt (Acon _ _ vbs e) = freevarsExp e \\ (map fst vbs)
 606         freevarsAlt (Alit _ e) = freevarsExp e
 607         freevarsAlt (Adefault e) = freevarsExp e
 608 freevarsExp (Cast e _) = freevarsExp e
 609 freevarsExp (Note _ e) =  freevarsExp e
 610 freevarsExp (External _ _) = []
 611
 612 stateToken :: Exp
 613 stateToken = Var (qual primMname "realWorldzh")
 614
 615 unitCon :: Exp
 616 unitCon = Dcon (qual baseMname "Z0T")