1 -- Copyright (c) 2000 Galois Connections, Inc. 2 -- All rights reserved. This software is distributed as 3 -- free software under the license in the file "LICENSE", 4 -- which is included in the distribution. 5 6 module Eval where 7 8 import Data.Array 9 10 import Geometry 11 import CSG 12 import Surface 13 import Data 14 import Parse (rayParse, rayParseF) 15 16 class Monad m => MonadEval m where 17 doOp :: PrimOp -> GMLOp -> Stack -> m Stack 18 tick :: m () 19 err :: String -> m a 20 21 -- entered oncetick = return () 22 23 newtype Pure a = Pure a deriving -- never entered-- never enteredShow 24 25 instance Monad Pure where 26 -- entered 10,417,773 timesPure x >>= k = k x 27 -- entered oncereturn = Pure 28 -- never enteredfail s = error s 29 30 instance MonadEval Pure where 31 -- entered oncedoOp = doPureOp 32 -- never enterederr s = error s 33 34 instance MonadEval IO where 35 -- entered 14 timesdoOp prim op stk = do { -- putStrLn ("Calling " ++ show op 36 -- ++ " << " ++ show stk ++ " >>") 37 doAllOp prim op stk 38 } 39 -- never enterederr s = error s 40 41 data State 42 = State { env :: Env 43 , stack :: Stack 44 , code :: Code 45 } deriving -- never entered-- never enteredShow 46 47 callback :: Env -> Code -> Stack -> Stack 48 -- entered 32,512 timescallback env code stk 49 = case eval (State { env = env, stack = stk, code = code}) of 50 Pure stk -> stk 51 52 {-# SPECIALIZE eval :: State -> Pure Stack #-} 53 {-# SPECIALIZE eval :: State -> IO Stack #-} 54 55 eval :: MonadEval m => State -> m Stack 56 -- entered 3,328,798 timeseval st = 57 do { () <- return () -- $ unsafePerformIO (print st) -- Functional debugger 58 ; if moreCode st then 59 do { tick -- tick first, so as to catch loops on new eval. 60 ; st' <- step st 61 ; eval st' 62 } 63 else return (stack st) 64 } 65 66 moreCode :: State -> Bool 67 -- entered 3,328,798 timesmoreCode (State {code = []}) = False 68 moreCode _ = True 69 70 -- Step has a precondition that there *is* code to run 71 {-# SPECIALIZE step :: State -> Pure State #-} 72 {-# SPECIALIZE step :: State -> IO State #-} 73 step :: MonadEval m => State -> m State 74 75 -- Rule 1: Pushing BaseValues 76 -- entered 3,059,036 timesstep st@(State{ stack = stack, code = (TBool b):cs }) 77 = return (st { stack = (VBool b):stack, code = cs }) 78 step st@(State{ stack = stack, code = (TInt i):cs }) 79 = return (st { stack = (VInt i):stack, code = cs }) 80 step st@(State{ stack = stack, code = (TReal r):cs }) 81 = return (st { stack = (VReal r):stack, code = cs }) 82 step st@(State{ stack = stack, code = (TString s):cs }) 83 = return (st { stack = (VString s):stack, code = cs }) 84 85 -- Rule 2: Name binding 86 step st@(State{ env = env, stack = (v:stack), code = (TBind id):cs }) = 87 return (State { env = extendEnv env id v, stack = stack, code = cs }) 88 step st@(State{ env = env, stack = [], code = (TBind id):cs }) = 89 err "Attempt to bind the top of an empty stack" 90 91 -- Rule 3: Name lookup 92 step st@(State{ env = env, stack = stack, code = (TId id):cs }) = 93 case (lookupEnv env id) of 94 Just v -> return (st { stack = v:stack, code = cs }) 95 Nothing -> err ("Cannot find value for identifier: " ++ id) 96 97 -- Rule 4: Closure creation 98 step st@(State{ env = env, stack = stack, code = (TBody body):cs }) = 99 return (st { stack = (VClosure env body):stack, code = cs }) 100 101 -- Rule 5: Application 102 step st@(State{ env = env, stack = (VClosure env' code'):stack, code = TApply:cs }) = 103 do { stk <- eval (State {env = env', stack = stack, code = code'}) 104 ; return (st { stack = stk, code = cs }) 105 } 106 step st@(State{ env = env, stack = [], code = TApply:cs }) = 107 err "Application with an empty stack" 108 step st@(State{ env = env, stack = _:_, code = TApply:cs }) = 109 err "Application of a non-closure" 110 111 -- Rule 6: Arrays 112 step st@(State{ env = env, stack = stack, code = TArray code':cs }) = 113 do { stk <- eval (State {env = env, stack = [], code = code'}) 114 ; let last = length stk-1 115 ; let arr = array (0,last) (zip [last,last-1..] stk) 116 ; return (st { stack = (VArray arr):stack, code = cs }) 117 } 118 119 -- Rule 7 & 8: If statement 120 step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool True):stack, code = TIf:cs }) = 121 do { stk <- eval (State {env = e1, stack = stack, code = c1}) 122 ; return (st { stack = stk, code = cs }) 123 } 124 step st@(State{ env = env, stack = (VClosure e2 c2):(VClosure e1 c1):(VBool False):stack, code = TIf:cs }) = 125 do { stk <- eval (State {env = e2, stack = stack, code = c2}) 126 ; return (st { stack = stk, code = cs }) 127 } 128 step st@(State{ env = env, stack = _, code = TIf:cs }) = 129 err "Incorrect use of if (bad and/or inappropriate values on the stack)" 130 131 -- Rule 9: Operators 132 step st@(State{ env = env, stack = stack, code = (TOp op):cs }) = 133 do { stk <- doOp (opFnTable ! op) op stack 134 ; return (st { stack = stk, code = cs }) 135 } 136 137 -- Rule Opps 138 step _ = err "Tripped on sidewalk while stepping." 139 140 141 -------------------------------------------------------------------------- 142 -- Operator code 143 144 opFnTable :: Array GMLOp PrimOp 145 -- entered onceopFnTable = array (minBound,maxBound) 146 [ (op,prim) | (_,TOp op,prim) <- opcodes ] 147 148 149 150 151 doPureOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack 152 -- entered 746,091 timesdoPureOp _ Op_render _ = 153 err ("\nAttempting to call render from inside a purely functional callback.") 154 doPureOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators 155 156 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Pure Stack #-} 157 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> IO Stack #-} 158 {-# SPECIALIZE doPrimOp :: PrimOp -> GMLOp -> Stack -> Abs Stack #-} 159 160 doPrimOp :: (MonadEval m) => PrimOp -> GMLOp -> Stack -> m Stack 161 162 -- 1 argument. 163 164 -- entered 746,104 timesdoPrimOp (Int_Int fn) _ (VInt i1:stk) 165 = return ((VInt (fn i1)) : stk) 166 doPrimOp (Real_Real fn) _ (VReal r1:stk) 167 = return ((VReal (fn r1)) : stk) 168 doPrimOp (Point_Real fn) _ (VPoint x y z:stk) 169 = return ((VReal (fn x y z)) : stk) 170 171 -- This is where the callbacks happen from... 172 doPrimOp (Surface_Obj fn) _ (VClosure env code:stk) 173 = case absapply env code [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] of 174 Just [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] -> 175 let 176 res = prop (color c1 c2 c3) r1 r2 r3 177 in 178 return ((VObject (fn (SConst res))) : stk) 179 _ -> return ((VObject (fn (SFun call))) : stk) 180 where 181 -- The most general case 182 call i r1 r2 = 183 case callback env code [VReal r2,VReal r1,VInt i] of 184 [VReal r3,VReal r2,VReal r1,VPoint c1 c2 c3] 185 -> prop (color c1 c2 c3) r1 r2 r3 186 stk -> error ("callback failed: incorrectly typed return arguments" 187 ++ show stk) 188 189 doPrimOp (Real_Int fn) _ (VReal r1:stk) 190 = return ((VInt (fn r1)) : stk) 191 doPrimOp (Int_Real fn) _ (VInt r1:stk) 192 = return ((VReal (fn r1)) : stk) 193 doPrimOp (Arr_Int fn) _ (VArray arr:stk) 194 = return ((VInt (fn arr)) : stk) 195 196 -- 2 arguments. 197 198 doPrimOp (Int_Int_Int fn) _ (VInt i2:VInt i1:stk) 199 = return ((VInt (fn i1 i2)) : stk) 200 doPrimOp (Int_Int_Bool fn) _ (VInt i2:VInt i1:stk) 201 = return ((VBool (fn i1 i2)) : stk) 202 doPrimOp (Real_Real_Real fn) _ (VReal r2:VReal r1:stk) 203 = return ((VReal (fn r1 r2)) : stk) 204 doPrimOp (Real_Real_Bool fn) _ (VReal r2:VReal r1:stk) 205 = return ((VBool (fn r1 r2)) : stk) 206 doPrimOp (Arr_Int_Value fn) _ (VInt i:VArray arr:stk) 207 = return ((fn arr i) : stk) 208 209 210 -- Many arguments, typically image mangling 211 212 doPrimOp (Obj_Obj_Obj fn) _ (VObject o2:VObject o1:stk) 213 = return ((VObject (fn o1 o2)) : stk) 214 doPrimOp (Point_Color_Light fn) _ (VPoint r g b:VPoint x y z : stk) 215 = return (VLight (fn (x,y,z) (color r g b)) : stk) 216 doPrimOp (Point_Point_Color_Real_Real_Light fn) _ 217 (VReal r2:VReal r1:VPoint r g b:VPoint x2 y2 z2:VPoint x1 y1 z1 : stk) 218 = return (VLight (fn (x1,y1,z1) (x2,y2,z2) (color r g b) r1 r2) : stk) 219 doPrimOp (Real_Real_Real_Point fn) _ (VReal r3:VReal r2:VReal r1:stk) 220 = return ((fn r1 r2 r3) : stk) 221 doPrimOp (Obj_Real_Obj fn) _ (VReal r:VObject o:stk) 222 = return (VObject (fn o r) : stk) 223 doPrimOp (Obj_Real_Real_Real_Obj fn) _ (VReal r3:VReal r2:VReal r1:VObject o:stk) 224 = return (VObject (fn o r1 r2 r3) : stk) 225 226 -- This one is our testing harness 227 doPrimOp (Value_String_Value fn) _ (VString s:o:stk) 228 = res `seq` return (res : stk) 229 where 230 res = fn o s 231 232 doPrimOp primOp op args 233 = err ("\n\ntype error when attempting to execute builtin primitive \"" ++ 234 show op ++ "\"\n\n| " ++ 235 show op ++ " takes " ++ show (length types) ++ " argument" ++ s 236 ++ " with" ++ the ++ " type" ++ s ++ "\n|\n|" ++ 237 " " ++ unwords [ show ty | ty <- types ] ++ "\n|\n|" ++ 238 " currently, the relevent argument" ++ s ++ " on the stack " ++ 239 are ++ "\n|\n| " ++ 240 unwords [ "(" ++ show arg ++ ")" 241 | arg <- reverse (take (length types) args) ] ++ "\n|\n| " 242 ++ " (top of stack is on the right hand side)\n\n") 243 where 244 len = length types 245 s = (if len /= 1 then "s" else "") 246 are = (if len /= 1 then "are" else "is") 247 the = (if len /= 1 then "" else " the") 248 types = getPrimOpType primOp 249 250 251 -- Render is somewhat funny, becauase it can only get called at top level. 252 -- All other operations are purely functional. 253 254 doAllOp :: PrimOp -> GMLOp -> Stack -> IO Stack 255 -- entered 14 timesdoAllOp (Render render) Op_render 256 (VString str:VInt ht:VInt wid:VReal fov 257 :VInt dep:VObject obj:VArray arr 258 :VPoint r g b : stk) 259 = do { render (color r g b) lights obj dep (fov * (pi / 180.0)) wid ht str 260 ; return stk 261 } 262 where 263 lights = [ light | (VLight light) <- elems arr ] 264 265 doAllOp primOp op stk = doPrimOp primOp op stk -- call the purely functional operators 266 267 ------------------------------------------------------------------------------ 268 {- 269 - Abstract evaluation. 270 - 271 - The idea is you check for constant code that 272 - (1) does not look at its arguments 273 - (2) gives a fixed result 274 - 275 - We run for 100 steps. 276 - 277 -} 278 279 absapply :: Env -> Code -> Stack -> Maybe Stack 280 -- entered 2 timesabsapply env code stk = 281 case runAbs (eval (State env stk code)) 100 of 282 AbsState stk _ -> Just stk 283 AbsFail m -> Nothing 284 285 newtype Abs a = Abs { runAbs :: Int -> AbsState a } 286 data AbsState a = AbsState a !Int 287 | AbsFail String 288 289 instance Monad Abs where 290 -- entered 54 times(Abs fn) >>= k = Abs (\ s -> case fn s of 291 AbsState r s' -> runAbs (k r) s' 292 AbsFail m -> AbsFail m) 293 -- entered 15 timesreturn x = Abs (\ n -> AbsState x n) 294 -- entered 2 timesfail s = Abs (\ n -> AbsFail s) 295 296 instance MonadEval Abs where 297 -- entered oncedoOp = doAbsOp 298 -- entered onceerr = fail 299 -- entered oncetick = Abs (\ n -> if n <= 0 300 then AbsFail "run out of time" 301 else AbsState () (n-1)) 302 303 doAbsOp :: PrimOp -> GMLOp -> Stack -> Abs Stack 304 -- entered 2 timesdoAbsOp _ Op_point (VReal r3:VReal r2:VReal r1:stk) 305 = return ((VPoint r1 r2 r3) : stk) 306 -- here, you could have an (AbsPoint :: AbsObj) which you put on the 307 -- stack, with any object in the three fields. 308 doAbsOp _ op _ = err ("operator not understood (" ++ show op ++ ")") 309 310 ------------------------------------------------------------------------------ 311 -- Driver 312 313 mainEval :: Code -> IO () 314 -- entered oncemainEval prog = do { stk <- eval (State emptyEnv [] prog) 315 ; return () 316 } 317 {- 318 * Oops, one of the example actually has something 319 * on the stack at the end. 320 * Oh well... 321 ; if null stk 322 then return () 323 else do { putStrLn done 324 ; print stk 325 } 326 -} 327 328 -- never entereddone = "Items still on stack at (successfull) termination of program" 329 330 ------------------------------------------------------------------------------ 331 -- testing 332 333 test :: String -> Pure Stack 334 -- never enteredtest is = eval (State emptyEnv [] (rayParse is)) 335 336 testF :: String -> IO Stack 337 -- never enteredtestF is = do prog <- rayParseF is 338 eval (State emptyEnv [] prog) 339 340 testA :: String -> Either String (Stack,Int) 341 -- never enteredtestA is = case runAbs (eval (State emptyEnv 342 [VAbsObj AbsFACE,VAbsObj AbsU,VAbsObj AbsV] 343 (rayParse is))) 100 of 344 AbsState a n -> Right (a,n) 345 AbsFail m -> Left m 346 347 -- never enteredabstest1 = "1.0 0.0 0.0 point /red { /v /u /face red 1.0 0.0 1.0 } apply" 348 349 -- should be [3:: Int] 350 -- never enteredet1 = test "1 /x { x } /f 2 /x f apply x addi" 351 352 353 354 355