Eval.hs (42133B)
1 -- Copyright 2023 The Plunder Authors 2 -- Use of this source code is governed by a BSD-style license that can be 3 -- found in the LICENSE file. 4 5 {-# OPTIONS_GHC -Wall #-} 6 {-# OPTIONS_GHC -Werror #-} 7 {-# OPTIONS_GHC -Wno-orphans #-} 8 9 -- TODO Lazy hack, do better (w.r.t re-export list?) 10 11 module Fan.Eval 12 ( Fan(..) 13 , PrimopCrash(..) 14 , Nat 15 , Pin(..) 16 , Law(..) 17 , trueArity 18 , lawNameText 19 , fastValEq 20 , natArity 21 , isPin 22 , LawName(..) 23 , valName 24 , valTag 25 , boom 26 , matchData 27 , toNat 28 , (%%) 29 , executeLaw 30 , compileLaw 31 , mkPin 32 , mkPin' 33 , mkLaw 34 , mkLawPreNormalized 35 , appN 36 , kloList 37 , kloWalk 38 , kloArgs 39 , fanIdx 40 , mkRow 41 , evalArity 42 , vTrkFan 43 , vTrkRex 44 , vShowFan 45 , vJetMatch 46 , vRtsConfig 47 , normalize 48 , trkName 49 , loadPinFromBlob 50 , tabValsRow 51 , setToRow 52 , lawName 53 , lawArgs 54 , lawBody 55 ) 56 where 57 58 import Data.Sorted 59 import Fan.Prof 60 import Fan.RunHashes 61 import Fan.Types 62 import Fan.Util 63 import PlunderPrelude hiding (hash) 64 65 import Control.Exception (throw) 66 import Control.Monad.ST (ST) 67 import Data.Char (isAlphaNum) 68 import Fan.Eval.Strictness (optimizeSpine) 69 import Fan.FFI (c_revmemcmp) 70 import Fan.PinRefs (pinRefs) 71 import GHC.Prim (reallyUnsafePtrEquality#) 72 import Hash256 (shortHex) 73 74 import {-# SOURCE #-} Fan.Hash (fanHash) 75 76 import qualified Data.ByteString as BS 77 import qualified Data.ByteString.Unsafe as BS 78 import qualified Data.Char as C 79 import qualified Data.Foldable as F 80 import qualified Data.Map as M 81 import qualified Data.Vector as V 82 import qualified Data.Vector.Storable as SV 83 import qualified Fan.Eval.LetRec as LetRec 84 import qualified GHC.Exts as GHC 85 86 87 -- Infix Operators ------------------------------------------------------------- 88 89 90 infixl 5 %%; 91 92 93 -- Globals --------------------------------------------------------------------- 94 95 -- These should all be overwritten on startup. These exists to break 96 -- dependency cycles, and aren't intended to support dynamic changes. 97 98 vTrkFan :: IORef (Fan -> IO ()) 99 vTrkFan = unsafePerformIO $ newIORef $ const $ pure () 100 101 vTrkRex :: IORef (Rex -> IO ()) 102 vTrkRex = unsafePerformIO $ newIORef $ const $ pure () 103 104 vShowFan :: IORef (Fan -> Text) 105 vShowFan = unsafePerformIO $ newIORef $ const "[PLUN]" 106 107 vJetMatch :: IORef (Pin -> IO Pin) 108 vJetMatch = unsafePerformIO (newIORef pure) 109 110 vRtsConfig :: IORef RtsConfig 111 vRtsConfig = unsafePerformIO $ newIORef $ RTS_CONFIG 112 { onJetFallback = WARN 113 , onJetMismatch = WARN 114 } 115 116 -- Types ----------------------------------------------------------------------- 117 118 instance Show LawName where 119 show = either show show . natUtf8 . (.nat) 120 121 instance Show Law where 122 show law = concat 123 [ "(LAW " 124 , unpack (ugly law.name.nat) 125 , " " 126 , show law.args 127 , " " 128 , show law.body 129 , ")" 130 ] 131 132 instance Eq Law where 133 (==) x@(L n a b _) y@(L nn aa bb _) = 134 case reallyUnsafePtrEquality# x y of 135 1# -> True 136 _ -> a==aa && n==nn && b==bb 137 138 -- TODO What if the small array has extra shit, and that shit can't 139 -- safely be forced? Don't do `mapSmallArray`, do it by hand. 140 normalize :: Fan -> Fan 141 normalize top = 142 if isNormal top then top else go top 143 where 144 isNormal (KLO _ xs) = 145 case xs .! 0 of 146 KLO{} -> False 147 _ -> all isNormal (toList xs) 148 isNormal (ROW v) = all isNormal v 149 isNormal (TAb t) = all isNormal t 150 isNormal !_ = True 151 152 go tp = case tp of 153 NAT !_ -> tp 154 BAR !_ -> tp 155 PIN !_ -> tp 156 FUN !_ -> tp 157 COw !_ -> tp 158 SET !_ -> tp 159 ROW r -> ROW (go <$> r) 160 TAb t -> TAb (go <$> t) 161 KLO r eRaw -> 162 let e = mapSmallArray' go eRaw in 163 case (e .! 0) of 164 KLO _ ee -> 165 let !w = sizeofSmallArray e 166 !ww = sizeofSmallArray ee 167 len = ww + (w-1) 168 in 169 KLO r $ createSmallArray len (NAT 999) \a -> do 170 copySmallArray a 0 ee 0 ww 171 copySmallArray a ww e 1 (w-1) 172 _ -> KLO r e 173 174 instance Show Pin where 175 show pin = unpack (valName pin.item) 176 177 instance Eq Pin where 178 (==) x y = 179 case reallyUnsafePtrEquality# x y of 180 1# -> True 181 _ -> x.hash == y.hash 182 183 {- 184 Comparision of two values that are likely to be pointer-equals. 185 186 We always do this check on laws and pins, since they are big 187 structures that are usually pointer-equals if they are equals. 188 189 We don't want to do this on every single value equality check, 190 though. It's expensive. 191 192 TODO: Test to see if we are actually gaining anything from this. 193 194 TODO: Consider getting rid of this, it isn't a huge problem if 195 laws comparisons are expensive, and pin comparisons just use the 196 hash anyways. 197 -} 198 fastValEq :: Fan -> Fan -> Bool 199 fastValEq x y = 200 case reallyUnsafePtrEquality# x y of 201 1# -> True 202 _ -> x == y 203 204 -- TODO Make sure evaluation order is correct. Don't evaluate more or 205 -- less than formal impl. 206 instance Eq Fan where 207 NAT n == NAT m = (n==m) 208 PIN p == PIN q = (p==q) 209 BAR b == BAR d = (b==d) 210 ROW r == ROW s = (r==s) 211 TAb t == TAb u = (t==u) 212 SET c == SET d = (c==d) 213 COw n == COw m = (n==m) 214 FUN l == FUN a = (l==a) 215 v@KLO{} == w@KLO{} = (kloWalk v == kloWalk w) 216 _ == _ = False 217 218 instance Ord Pin where 219 compare x y = 220 case GHC.reallyUnsafePtrEquality x y of 221 1# -> EQ 222 _ -> unsafePerformIO do 223 pure $ if x.hash == y.hash 224 then EQ 225 else compare x.item y.item 226 227 {- 228 TODO: This is pretty complicated. Test the shit out of this. 229 230 TODO: Try to reduce code duplication between lawName/etc and `boom`. 231 It's difficult because boom is very performance sensitive. 232 233 TODO: This is going to need some explaination. 234 -} 235 instance Ord Fan where 236 compare (NAT x) (NAT y) = compare x y 237 compare (NAT _) _ = LT 238 compare _ (NAT _) = GT 239 240 compare (PIN x) (PIN y) = compare x y 241 compare (PIN _) _ = LT 242 compare _ (PIN _) = GT 243 244 compare (BAR x) (BAR y) = 245 let !xw = length x in 246 let !yw = length y in 247 case compare xw yw of 248 LT -> LT 249 GT -> GT 250 EQ -> unsafePerformIO $ 251 BS.unsafeUseAsCString x \xBuf -> 252 BS.unsafeUseAsCString y \yBuf -> do 253 i <- c_revmemcmp xBuf yBuf (fromIntegral xw) 254 pure (compare i 0) 255 256 compare x y = 257 case (fanLen x, fanLen y) of 258 (0, 0) -> 259 compare (lawName x) (lawName y) 260 <> compare (lawArgs x) (lawArgs y) 261 <> compare (lawBody x) (lawBody y) 262 263 (xw, yw) -> 264 compare xw yw 265 <> concat (zipWith compare (fanSeq x) (fanSeq y)) 266 where 267 fanLen (ROW r) = length r 268 fanLen TAb{} = 1 269 fanLen (KLO _ k) = (sizeofSmallArray k) - 1 270 -- ^ TODO: This is false if the fan is not normalized. Not a 271 -- safe assumption. 272 fanLen _ = 0 273 274 nat = fromIntegral 275 276 fanSeq f = case f of 277 NAT{} -> [f] 278 FUN{} -> [f] 279 BAR{} -> [f] 280 PIN{} -> [f] 281 SET{} -> [f] 282 COw{} -> [f] 283 ROW r -> if null r then [f] else COw (nat(length r)) : reverse (toList r) -- COw here is never empty 284 KLO _ k -> toList k 285 TAb t -> [SET (tabKeysSet t), ROW (fromList $ toList t)] 286 287 {-# INLINE lawName #-} 288 lawName :: Fan -> Nat 289 lawName = \case 290 FUN l -> l.name.nat 291 NAT{} -> 0 292 PIN{} -> 0 293 KLO{} -> 0 294 BAR{} -> 1 295 ROW{} -> 0 296 TAb{} -> 0 297 SET{} -> 1 298 COw{} -> 0 299 300 {-# INLINE lawArgs #-} 301 lawArgs :: Fan -> Nat 302 lawArgs = \case 303 FUN l -> l.args 304 PIN p -> p.args 305 BAR{} -> 1 306 COw c -> c+1 307 ROW r -> if null r then 1 else 0 -- Only a law if empty 308 SET{} -> 2 309 TAb{} -> 0 -- Not a function 310 KLO{} -> 0 -- Not a function 311 NAT{} -> 0 -- Not a function 312 313 setToRow :: ArraySet Fan -> Fan 314 setToRow set = ROW (ssetToArray set) 315 316 {-# INLINE lawBody #-} 317 lawBody :: Fan -> Fan 318 lawBody = \case 319 FUN l -> l.body 320 BAR b -> NAT (barBody b) 321 SET k -> setToRow k 322 COw{} -> NAT 0 -- Actual law body is 0 323 ROW{} -> NAT 0 -- Actual law body is 0 324 TAb{} -> NAT 0 -- Not a law 325 NAT{} -> NAT 0 -- Not a law 326 KLO{} -> NAT 0 -- Not a law 327 PIN{} -> NAT 0 -- Not a law 328 329 boom :: Fan -> (Fan, Fan) 330 boom = \case 331 NAT{} -> 332 (NAT 0, NAT 0) 333 334 FUN law -> 335 rul law.name law.args law.body 336 337 BAR b -> 338 rul (LN 1) 1 (NAT $ barBody b) 339 340 PIN p -> 341 (NAT 4, p.item) 342 343 COw n -> 344 rul (LN 0) (n+1) (NAT 0) 345 346 -- When we take the head of a closure with more than two elements, 347 -- we essentially create a lazy-list of width=2 closure nodes. 348 KLO arity xs -> 349 case sizeofSmallArray xs of 350 2 -> ( xs.!0 , xs.!1 ) 351 len -> ( let 352 flow !_ !0 = xs.!0 353 flow !r !i = KLO (r+1) (a2 (flow (r+1) (i-1)) (xs.!i)) 354 in 355 flow arity (len-2) 356 , xs.!(len-1) 357 ) 358 359 -- Builds lazy list of two-element KLO nodes. 360 ROW row -> 361 let !len = length row in 362 case len of 363 0 -> boom (COw 0) 364 1 -> (COw 1, row ! 0) 365 n -> ( let 366 flow !i !0 = COw (fromIntegral i) -- i is never 0 367 flow !i !ram = KLO i $ a2 (flow (i+1) (ram-1)) (row ! i) 368 in 369 flow 1 (n-1) 370 , 371 row ! 0 372 ) 373 374 TAb tab -> 375 ( SET $ tabKeysSet tab 376 , ROW $ tabElemsArray tab 377 ) 378 379 SET ks -> 380 rul (LN 1) 2 (ROW $ ssetToArray ks) 381 382 where 383 rul :: LawName -> Nat -> Fan -> (Fan, Fan) 384 rul (LN n) a b = 385 ( KLO 1 (a3 (NAT 0) (NAT n) (NAT a)) 386 , b 387 ) 388 389 valName :: Fan -> Text 390 valName = \case 391 FUN law -> ugul law.name.nat 392 PIN pin -> valName pin.item 393 _ -> "_" 394 where 395 ok '_' = True 396 ok c = C.isAlphaNum c 397 398 ugul :: Nat -> Text 399 ugul 0 = "anon" 400 ugul nat = case natUtf8 nat of 401 Right t | all ok t -> t 402 _ -> tshow nat 403 404 valTag :: Fan -> Nat 405 valTag (FUN law) = law.name.nat 406 valTag (PIN pin) = valTag pin.item 407 valTag _ = 0 408 409 instance Show Fan where 410 show (NAT n) = ugly n 411 show (KLO _ x) = show (toList x) 412 show (FUN l) = show l 413 show (PIN p) = show p 414 show (COw n) = "R" <> show n 415 show (ROW v) = "(ROW " <> show v <> ")" 416 show (TAb t) = "(TAB " <> show (showTab t) <> ")" 417 show (SET k) = "(SET " <> show (toList k) <> ")" 418 show (BAR b) = "(BAR " <> show b <> ")" 419 420 showTab :: Tab Fan Fan -> [(Fan,Fan)] 421 showTab t = tabToAscPairsList t 422 423 -- Utilities ------------------------------------------------------------------- 424 425 isPin :: Fan -> Bool 426 isPin PIN{} = True 427 isPin _ = False 428 429 lawNameText :: LawName -> Text 430 lawNameText (LN 0) = "_" 431 lawNameText (LN n) = 432 case natUtf8 n of 433 Left _ -> fallback 434 Right t -> 435 let cs = unpack t 436 in if | all isNameChar cs -> t 437 | otherwise -> fallback 438 where 439 fallback = "_/" <> tshow n 440 441 isNameChar '_' = True 442 isNameChar c = isAlphaNum c 443 444 instance IsString LawName where 445 fromString = LN . bytesNat . encodeUtf8 . pack 446 447 448 -------------------------------------------------------------------------------- 449 450 barBody :: ByteString -> Nat 451 barBody bytes = 452 -- TODO Make this not slow 453 bytesNat (bytes <> BS.singleton 1) 454 455 -------------------------------------------------------------------------------- 456 457 matchData :: LawName -> Nat -> Fan -> Maybe Fan 458 matchData (LN 0) 1 (NAT 0) = Just $ ROW mempty 459 matchData (LN 0) n (NAT 0) = Just $ COw (n-1) -- n-1 is never zero 460 matchData (LN 1) 2 (ROW v) = matchSet v 461 matchData (LN 1) 1 (NAT n) = matchBar n 462 matchData (LN _) _ _ = Nothing 463 464 matchBar :: Nat -> Maybe Fan 465 matchBar n = do 466 guard (n /= 0) 467 let bitWidth = (natBitWidth n :: Nat) - 1 468 guard (0 == (bitWidth `mod` 8)) 469 let bytWidth = fromIntegral (bitWidth `div` 8) 470 pure $ BAR $ take bytWidth $ natBytes n 471 472 matchSet :: Array Fan -> Maybe Fan 473 matchSet vs = do 474 case toList vs of 475 [] -> Just (SET mempty) 476 a:es -> collect mempty a es 477 where 478 collect !acc i [] = pure (SET $ insertSet i acc) 479 collect !acc i (w:ws) | w>i = collect (insertSet i acc) w ws 480 collect _ _ _ = Nothing 481 482 483 -- Constructing Pins and Laws -------------------------------------------------- 484 485 mkLawPreNormalized :: LawName -> Nat -> Fan -> Fan 486 mkLawPreNormalized nam arg bod = 487 if arg==0 488 then throw (PRIMOP_CRASH 0 0) 489 else fromMaybe (FUN $ L nam arg bod $ compileLaw nam arg bod) 490 $ matchData nam arg bod 491 492 mkLaw :: LawName -> Nat -> Fan -> Fan 493 mkLaw nam arg bod = mkLawPreNormalized nam arg (normalize bod) 494 495 mkPin :: Fan -> Fan 496 mkPin = PIN . unsafePerformIO . mkPin' 497 498 frameSize :: Fan -> Int 499 frameSize (KLO _ e) = frameSize (e.!0) 500 frameSize v = 1 + evalArity v 501 502 {- 503 These are called extremely often, and we don't want to bog down 504 the system by emiting profiling events for them. 505 -} 506 highFreqLaws :: Set Nat 507 highFreqLaws = setFromList 508 ( 509 [ "dec", "add", "mul", "sub", "bex", "lte", "lth", "div" 510 , "mod", "aeq", "lsh", "rsh", "met", "mix", "dis", "con" 511 , "if", "eql", "trk", "idx", "get", "len" 512 , "weld", "map", "put", "mut", "take", "drop", "cat", "rev" 513 , "w32", "add32", "mul32", "div32", "and32", "or32", "xor32" 514 , "lsh32", "rsh32", "sub32", "ror32", "rol32", "isBar", "barIdx" 515 , "barWeld", "barCat", "barFlat", "natBar", "barDrop", "barTake" 516 , "barLen", "barNat", "setSingleton", "setIns", "setDel", "setMin" 517 , "setLen", "setUnion", "setHas", "setSplitAt", "setSplitLT" 518 , "setIntersection", "tabSingleton", "tabIdx", "tabElem" 519 , "tabLookup", "tabToPairs", "gth", "gte", "bit", "not", "and" 520 , "neq", "isNat" 521 ] :: [Nat] 522 ) 523 524 addProfilingToPin :: Pin -> IO Pin 525 addProfilingToPin pin = do 526 enab <- lawProfilingEnabled 527 528 let shouldProfile = 529 case pin.item of 530 FUN l -> not $ member l.name.nat highFreqLaws 531 _ -> False 532 533 if not (enab && shouldProfile) then do 534 pure pin 535 else do 536 let nam = encodeUtf8 (valName pin.item) 537 let key = nam <> "-(" <> shortHex pin.hash <> ")" 538 pure (setExec (profWrap key pin.exec) pin) 539 where 540 profWrap tag fun args = 541 seq args $ unsafePerformIO do 542 withSimpleTracingEvent tag "fan" $ evaluate (fun args) 543 544 545 mkPin' :: Fan -> IO Pin 546 mkPin' inp = do 547 -- let putNam tx = putStrLn ("\n\n==== [[[" <> tx <> "]]] ====\n") 548 -- putNam (valName inp) 549 550 item <- evaluate (normalize inp) 551 match <- readIORef vJetMatch 552 553 res <- mdo let exe = pinExec (PIN res) item 554 let ari = trueArity item 555 let hax = fanHash item 556 let ref = pinRefs item 557 res <- addProfilingToPin =<< match (P ref hax ari item exe) 558 pure res 559 560 -- hack that causes functions to be serialized/hashed immediately. 561 case item of 562 FUN{} -> evaluate res.exec >> pure () 563 _ -> pure () 564 565 {- 566 We do not do deduplication here. Instead, we should deduplicate 567 the heap occasionally, after each snapshot. 568 569 Heap deduplication as a pass is relatively cheap, because we 570 are merely walking the pin-DAG and looking at the hashes. 571 572 If this were ever of significant cost, we can have a flag on 573 each thing to mark it as the canonical version. 574 -} 575 evaluate res 576 577 loadPinFromBlob :: Vector Pin -> Hash256 -> Fan -> IO Pin 578 loadPinFromBlob refs hax item = do 579 match <- readIORef vJetMatch 580 581 res <- mdo let slf = (PIN res) 582 let exe = case item of 583 FUN law -> \e -> executeLaw slf law.code law.code e 584 _ -> \e -> foldl' (%%) item (toList e) 585 -- TODO is this correct? 586 -- Doesn't the passed environment 587 -- include ourselves? 588 let !ari = trueArity item 589 res <- addProfilingToPin =<< match (P refs hax ari item exe) 590 pure res 591 592 evaluate res.exec 593 594 pure res 595 596 {-# INLINE pinExec #-} 597 pinExec :: Fan -> Fan -> (SmallArray Fan -> Fan) 598 pinExec self = \case 599 FUN law -> executeLaw self law.code law.code 600 item -> foldl' (%%) item . drop 1 . toList 601 602 603 -- Evaluation ------------------------------------------------------------------ 604 605 (%%) :: Fan -> Fan -> Fan 606 (%%) = app2 607 608 data APPLY = APPLY (Int, Int) [Fan] 609 deriving (Show) 610 611 app2 :: Fan -> Fan -> Fan 612 app2 f x = 613 case evalArity f of 614 1 -> eval2 f x 615 args -> KLO (args-1) (a2 f x) 616 617 app3 :: Fan -> Fan -> Fan -> Fan 618 app3 f x y = 619 case evalArity f of 620 1 -> app2 (eval2 f x) y 621 2 -> eval3 f x y 622 args -> KLO (args-2) (a3 f x y) 623 624 app4 :: Fan -> Fan -> Fan -> Fan -> Fan 625 app4 f x y z = 626 case evalArity f of 627 1 -> app3 (eval2 f x) y z 628 2 -> app2 (eval3 f x y) z 629 3 -> eval4 f x y z 630 args -> KLO (args-3) (a4 f x y z) 631 632 appN :: SmallArray Fan -> Fan 633 appN xs = 634 case sizeofSmallArray xs of 635 2 -> app2 (xs.!0) (xs.!1) 636 3 -> app3 (xs.!0) (xs.!1) (xs.!2) 637 4 -> app4 (xs.!0) (xs.!1) (xs.!2) (xs.!3) 638 !wid -> 639 let !arity = evalArity (xs.!0) 640 !need = arity+1 641 in 642 -- trace (ppShow $ APPLY (wid,need) (toList xs)) 643 case compare wid need of 644 EQ -> evalN (KLO 0 xs) 645 LT -> KLO (need-wid) xs 646 GT -> let 647 !hed = evalN $ KLO 0 (cloneSmallArray xs 0 need) 648 !xtr = wid - need 649 in 650 appN $ createSmallArray (xtr+1) hed \buf -> do 651 copySmallArray buf 1 xs need xtr 652 653 execFrame :: SmallArray Fan -> Fan 654 execFrame buf = 655 let x = buf.!0 in 656 case x of 657 FUN l -> executeLaw x l.code l.code buf 658 PIN p -> p.exec buf 659 ROW v -> mkCow (fromIntegral $ length v) 660 KLO{} -> error "Invalid stack frame, closure as head" 661 NAT n -> execNat n buf 662 BAR b -> if null b then buf.!1 else NAT (barBody b) 663 TAb t -> ROW (tabKeysArray t) -- tabs return keys row 664 COw n -> 665 let !las = fromIntegral n in 666 ROW $ rowGenerate (fromIntegral n) \i -> 667 (buf .! (las - i)) 668 669 SET ks -> 670 if sizeofSmallArray buf == 3 -- (set badVals arg) 671 then 672 -- This only happens if the first arguments was not a 673 -- valid values-row. Here we run the actual legal 674 -- behavior, which is to return the keys row. 675 ROW (ssetToArray ks) 676 else 677 case buf.!1 of 678 ROW vals | (length vals == length ks) -> 679 TAb (mkTab ks vals) 680 _ -> 681 KLO 1 buf 682 683 eval2 :: Fan -> Fan -> Fan 684 eval2 fn x1 = 685 case fn of 686 k@(KLO _ x) -> 687 case x.!0 of 688 KLO{} -> evalN (KLO 0 $ a2 k x1) 689 func -> let !w = sizeofSmallArray x in 690 valCode func $ createSmallArray (w+1) x1 \buf -> do 691 copySmallArray buf 0 x 0 w 692 _ -> 693 valCode fn (a2 fn x1) 694 695 eval3 :: Fan -> Fan -> Fan -> Fan 696 eval3 fn x1 x2 = 697 case fn of 698 k@(KLO _ x) -> 699 case x.!0 of 700 KLO{} -> evalN (KLO 0 $ a3 k x1 x2) 701 func -> let !w = sizeofSmallArray x in 702 valCode func $ createSmallArray (w+2) x2 \buf -> do 703 copySmallArray buf 0 x 0 w 704 writeSmallArray buf w x1 705 _ -> 706 valCode fn (a3 fn x1 x2) 707 708 eval4 :: Fan -> Fan -> Fan -> Fan -> Fan 709 eval4 fn x1 x2 x3 = 710 case fn of 711 k@(KLO _ x) -> 712 case x.!0 of 713 KLO{} -> evalN (KLO 0 $ a4 k x1 x2 x3) 714 func -> let !w = sizeofSmallArray x in 715 valCode func $ createSmallArray (w+3) x3 \buf -> do 716 copySmallArray buf 0 x 0 w 717 writeSmallArray buf w x1 718 writeSmallArray buf (w+1) x2 719 _ -> 720 valCode fn (a4 fn x1 x2 x3) 721 722 723 724 -- For example, to eval (f x y) do `evalN (KLO 0 3 [f,x,y])`. 725 evalN :: Fan -> Fan 726 evalN env = 727 -- trace ("evalN: " <> show env) 728 -- trace ("evalN: " <> show (frameSize env)) 729 execFrame $ createSmallArray (frameSize env) (NAT 0) \a -> do 730 void (fill a env) 731 where 732 fill :: ∀s. SmallMutableArray s Fan -> Fan -> ST s Int 733 fill buf = \case 734 KLO _ e -> do 735 !i <- fill buf (e.!0) 736 let !w = sizeofSmallArray e 737 let !v = w-1 738 copySmallArray buf i e 1 v 739 pure (i+v) 740 hed -> 741 writeSmallArray buf 0 hed $> 1 742 743 deriving instance Eq PrimopCrash 744 deriving instance Ord PrimopCrash 745 instance Exception PrimopCrash where 746 displayException (PRIMOP_CRASH n x) = 747 unsafePerformIO do 748 s <- readIORef vShowFan 749 pure $ concat [ "Evaluation crashed by calling the number " 750 , show n 751 , " with this argument:\n\n" 752 , unpack (s x) 753 ] 754 755 instance Show PrimopCrash where 756 show = displayException 757 758 execNat :: Nat -> SmallArray Fan -> Fan 759 execNat 0 e = mkLaw (LN $ toNat $ e.!1) (toNat $ e.!2) (e.!3) 760 execNat 1 e = wut (e.!1) (e.!2) (e.!3) (e.!4) (e.!5) 761 execNat 2 e = case toNat (e.!3) of 0 -> e.!1 762 n -> (e.!2) %% NAT(n-1) 763 execNat 3 e = NAT (toNat(e.!1) + 1) 764 execNat 4 e = mkPin (e.!1) 765 execNat n e = unsafePerformIO do 766 let arg = (e.!1) 767 evaluate (force arg) -- If arg crashes, throw that instead 768 Fan.Prof.recordInstantEvent "crash" "fan" $ 769 M.singleton "op" (Right $ tshow n) 770 throwIO (PRIMOP_CRASH n arg) 771 772 wut :: Fan -> Fan -> Fan -> Fan -> Fan -> Fan 773 wut p l a n = \case 774 x@NAT{} -> n %% x 775 x@KLO{} -> let (hd,tl) = boom x in app3 a hd tl 776 777 PIN pin -> p %% pin.item 778 779 FUN law -> 780 let nm = NAT law.name.nat 781 ar = NAT law.args 782 in app4 l nm ar law.body 783 784 BAR b -> app4 l (NAT 1) (NAT 1) (NAT $ barBody b) 785 COw m -> wutCow m 786 787 -- Always a pair 788 v@TAb{} -> let (hd,tl) = boom v in app3 a hd tl 789 790 SET k -> wutSet k 791 792 x@(ROW v) -> 793 if null v 794 then wutCow 0 795 else app3 a h t where (h,t) = boom x 796 where 797 wutCow m = app4 l (NAT 0) (NAT (m+1)) (NAT 0) 798 799 wutSet k = 800 app4 l (NAT 1) (NAT 2) (ROW $ ssetToArray k) 801 802 {- 803 PIN p -> rul (LN 0) args (pinBody args p.item) 804 where args = (trueArity p.item) 805 ROW v -> case reverse (toList v) of 806 [] -> rul (LN 0) 1 (AT 0) 807 x:xs -> apple (DAT $ COw sz) (x :| xs) 808 where sz = fromIntegral (length v) 809 TAB d -> tabWut d 810 BAR b -> rul (LN 1) 1 (AT $ barBody b) 811 COw n -> rul (LN 0) (n+1) (AT 0) 812 SET k -> setWut k 813 -} 814 815 {- 816 -- DAT dj -> dataWut goLaw goApp dj 817 -- where 818 -- goApp g y = a %% g %% y 819 -- goLaw nm ar bd = f %% NAT (lawNameNat nm) %% NAT ar %% bd 820 821 dataWut 822 :: ∀a 823 . (LawName -> Nat -> Pln -> a) 824 -> (Pln -> Pln -> a) 825 -> Dat 826 -> a 827 dataWut rul cel = \case 828 -} 829 830 831 cnsName :: Fan -> String 832 cnsName v = 833 let res = valName v 834 in if (null res || any (not . C.isPrint) res) 835 then show v 836 else unpack res 837 838 showCns :: Fan -> String 839 showCns v@KLO{} = "(KLO " <> intercalate " " (showCns <$> kloList v) <> ")" 840 showCns v@FUN{} = cnsName v 841 showCns v@PIN{} = cnsName v 842 showCns (ROW xs) = "(row " <> intercalate " " (fmap showCns xs) <> ")" 843 showCns COw{} = "COW" 844 showCns TAb{} = "TAB" 845 showCns SET{} = "SET" 846 showCns BAR{} = "BAR" 847 showCns (NAT n) = show n 848 849 instance Show Prog where 850 show p = "(PROG " 851 <> "{ arity =" <> show p.arity 852 <> ", varsSz=" <> show p.varsSz 853 <> ", prgrm=(" <> show p.prgrm <> ")" 854 <> "})" 855 856 showBind :: (Int, Run) -> String 857 showBind (i,x) = show (VAR i) <> " " <> show x 858 859 instance Show Run where 860 show (CNS c) = showCns c 861 show (ARG i) = "_" <> show i 862 show (VAR i) = "_v" <> show i 863 show (KAL xs) = "(KAL " <> intercalate " " (show <$> toList xs) <> ")" 864 865 show (EXE _ _ f xs) = 866 "(EXE " <> showCns f <> " " <> intercalate " " (show <$> toList xs) <> ")" 867 868 show (PAR n xs) = 869 "(PAR arity_is_" <> show n <> intercalate " " (show <$> toList xs) <> ")" 870 871 show (REC xs) = "(REC " <> intercalate " " (show <$> toList xs) <> ")" 872 873 show (TRK v b) = "(TRK " <> show v <> " " <> show b <> ")" 874 875 show (MK_ROW es) = "(MKROW " <> intercalate " " (show <$> es) <> ")" 876 877 show (MK_TAB vs) = "(MKTAB " <> intercalate " " (show <$> (tabToAscPairsList vs)) <> ")" 878 879 show (LETREC vs v) = 880 "(LETREC [" <> intercalate " " (showBind <$> vs) <> "] " <> show v <> ")" 881 show (LET i x v) = 882 "(LET " <> showBind (i,x) <> " " <> show v <> ")" 883 884 show (IF_ c t e) = 885 "(IF " <> show c <> " " <> show t <> " " <> show e <> ")" 886 887 show (IFZ c t e) = 888 "(IFZ " <> show c <> " " <> show t <> " " <> show e <> ")" 889 890 show (SEQ x b) = 891 "(SEQ " <> show x <> " " <> show b <> ")" 892 893 show (SWI x f v) = 894 parencalate ["ROW_SWITCH", show x, show f, show v] 895 896 show (JMP_WORD x f ks vs) = 897 parencalate ["TAB_SWITCH_WORDS", show x, show f, show v] 898 where 899 v = mapFromList (zip (toList ks) (toList vs)) :: Map Word Run 900 901 show (LAZ exe arg) = 902 parencalate ("LAZ" : show exe : (show <$> toList arg)) 903 904 show (JMP x f vs) = 905 parencalate ["TAB_SWITCH", show x, show f, show vs] 906 907 show (OP2 name _ a b) = 908 parencalate ["OP2", show name, show a, show b] 909 910 parencalate :: [String] -> String 911 parencalate xs = "(" <> intercalate " " xs <> ")" 912 913 -- Match row/tab constructors: (c2 y x) -> MK_ROW [x,y] 914 matchConstructors :: Run -> Run 915 matchConstructors = go 916 where 917 go = \case 918 LAZ{} -> error "matchConstructors: impossible" 919 SEQ v x -> SEQ (go v) (go x) 920 REC vs -> REC (go <$> vs) 921 KAL vs -> KAL (go <$> vs) 922 PAR r vs -> PAR r (go <$> vs) 923 TRK m x -> TRK (go m) (go x) 924 MK_ROW rs -> MK_ROW (go <$> rs) 925 MK_TAB vs -> MK_TAB (go <$> vs) 926 r@CNS{} -> r 927 r@ARG{} -> r 928 r@VAR{} -> r 929 LET i v b -> LET i (go v) (go b) 930 LETREC vs b -> LETREC (fmap go <$> vs) (go b) 931 IF_ c t e -> IF_ (go c) (go t) (go e) 932 IFZ c t e -> IFZ (go c) (go t) (go e) 933 SWI c f v -> SWI (go c) (go f) (go <$> v) 934 JMP c f vs -> JMP (go c) (go f) (go <$> vs) 935 JMP_WORD c f ks vs -> JMP_WORD (go c) (go f) ks (go <$> vs) 936 OP2 f op a b -> OP2 f op (go a) (go b) 937 938 EXE _ _ COw{} r -> do 939 go $ MK_ROW $ reverse $ fromList $ toList r 940 941 EXE _ _ (PIN p) r 942 | sizeofSmallArray r == 2 943 , Just (name, fun) <- matchPin p op2Table 944 -> go $ OP2 name fun (r.!0) (r.!1) 945 946 EXE _ _ (KLO 1 n) r 947 | [PIN p, a] <- F.toList n 948 , [b] <- F.toList r 949 , Just (name, fun) <- matchPin p op2Table 950 -> go $ OP2 name fun (CNS a) b 951 952 EXE x s (SET ks) r -> 953 if sizeofSmallArray r /= 1 then 954 error "TODO: Remove this check, since this should never happen" 955 else 956 case go (r.!0) of 957 MK_ROW vs | length vs == length ks -> 958 MK_TAB (mkTab ks $ V.toArray vs) 959 _ -> 960 EXE x s (SET ks) (go <$> r) 961 962 EXE x s (KLO n e) r -> 963 case e.!0 of 964 COw{} -> 965 go $ MK_ROW 966 $ fromList 967 $ reverse 968 $ ((fmap CNS $ drop 1 $ toList e) <>) 969 $ toList r 970 _ -> 971 EXE x s (KLO n e) (go <$> r) 972 973 EXE x s f r -> EXE x s f (go <$> r) 974 975 matchPin :: Pin 976 -> Map Hash256 (String, (Fan -> Fan -> Fan)) 977 -> Maybe (String, (Fan -> Fan -> Fan)) 978 matchPin p tbl = M.lookup p.hash tbl 979 980 valCode :: Fan -> (SmallArray Fan -> Fan) 981 valCode = \case 982 KLO _ x -> valCode (x.!0) 983 x@(FUN f) -> executeLaw x f.code f.code 984 PIN p -> p.exec 985 NAT n -> execNat n 986 ROW{} -> execFrame 987 BAR{} -> execFrame 988 TAb{} -> execFrame 989 COw{} -> execFrame 990 SET{} -> execFrame 991 992 -- Saturated calls become EXE nodes, undersaturated calls become KLO nodes. 993 resaturate :: Int -> Run -> Run 994 resaturate selfArgs = go 995 where 996 go LAZ{} = error "resaturate: impossible" 997 go EXE{} = error "resaturate: impossible" 998 go PAR{} = error "resaturate: impossible" 999 go MK_ROW{} = error "resaturate: impossible" 1000 go MK_TAB{} = error "resaturate: impossible" 1001 go IF_{} = error "resaturate: impossible" 1002 go IFZ{} = error "resaturate: impossible" 1003 go SWI{} = error "resaturate: impossible" 1004 go JMP{} = error "resaturate: impossible" 1005 go JMP_WORD{} = error "resaturate: impossible" 1006 go SEQ{} = error "resaturate: impossible" 1007 go REC{} = error "resaturate: impossible" 1008 go TRK{} = error "resaturate: impossible" 1009 go OP2{} = error "resaturate: impossible" 1010 1011 go c@CNS{} = c 1012 go r@VAR{} = r 1013 go a@ARG{} = a 1014 1015 -- go (EXE f xs) = EXE f xs 1016 -- go (PAR i xs) = PAR i xs 1017 go (LET i v b) = LET i (go v) (go b) 1018 go (LETREC vs b) = LETREC (fmap go <$> vs) (go b) 1019 go (KAL xs) = kal (toList xs) 1020 1021 kal (KAL ks : xs) = kal (toList ks <> xs) 1022 kal (CNS c : xs) = cns c (go <$> xs) 1023 kal (ARG 0 : xs) = sel (go <$> xs) 1024 kal xs = KAL (smallArrayFromList $ go <$> xs) 1025 1026 cns :: Fan -> [Run] -> Run 1027 cns f xs = 1028 let len = fromIntegral (length xs) 1029 r = evalArity f 1030 in 1031 case compare r len of 1032 -- TODO work harder to keep these flat? 1033 GT -> PAR (r-len) (smallArrayFromList (CNS f : xs)) 1034 EQ -> EXE (valCode f) (frameSize f) f (smallArrayFromList xs) 1035 LT -> KAL $ smallArrayFromList 1036 $ (EXE (valCode f) (frameSize f) f (smallArrayFromList $ take r xs) : drop r xs) 1037 1038 sel :: [Run] -> Run 1039 sel xs = 1040 let len = fromIntegral (length xs) 1041 r = selfArgs 1042 in 1043 case compare r len of 1044 -- TODO work harder to keep these flat? 1045 GT -> PAR (r-len) (smallArrayFromList (ARG 0 : xs)) 1046 EQ -> REC $ smallArrayFromList xs 1047 LT -> KAL $ smallArrayFromList 1048 $ ((REC $ smallArrayFromList $ take r xs) : drop r xs) 1049 1050 ugly :: Nat -> String 1051 ugly 0 = "0" 1052 ugly nat = 1053 let ok '_' = True 1054 ok c = C.isAlphaNum c 1055 in case natUtf8 nat of 1056 Right t | all ok t -> show t 1057 _ -> show nat 1058 1059 -- TODO: Review potential for overflow of `numArgs` 1060 compileLaw :: LawName -> Nat -> Fan -> Prog 1061 compileLaw _lawName numArgs lBod = 1062 let lxp = LetRec.loadLawBody numArgs lBod 1063 lxpOpt = LetRec.optimize (fromIntegral numArgs) lxp 1064 (code, maxVar) = LetRec.compile (fromIntegral numArgs) lxpOpt 1065 opt = resaturate (natToArity numArgs) code 1066 run = optimizeSpine (matchConstructors opt) 1067 prog = PROG (fromIntegral numArgs) 1068 (fromIntegral (maxVar + 1)) 1069 run 1070 in 1071 {- 1072 if True || _lawName == "flushDownwards" then 1073 trace (ppShow ( ("lawName"::Text, _lawName) 1074 , ("rawLxp"::Text, lxp) 1075 , ("optLxp"::Text, lxpOpt) 1076 , (("rawRun"::Text, code), ("maxVar"::Text, maxVar)) 1077 , ("semiOptimized"::Text, opt) 1078 , ("finalProg"::Text, prog) 1079 )) 1080 prog 1081 else 1082 -} 1083 prog 1084 where 1085 1086 {- 1087 recPro is different from exePro because, in a shattered-spine, we 1088 recurse into a different program (the outermost one) than the one 1089 we are running (the fragment). 1090 -} 1091 executeLaw :: Fan -> Prog -> Prog -> SmallArray Fan -> Fan 1092 executeLaw self recPro exePro args = 1093 unsafePerformIO do 1094 let numVars = exePro.varsSz 1095 1096 -- traceM ( "EXECUTING: " <> show pro <> "\n" 1097 -- <> "AGAINST: " <> show (toList args) 1098 -- ) 1099 1100 -- traceM ("EXECUTE LAW: " <> show self) 1101 -- traceM ("\t" <> show self) 1102 -- traceM ("\t" <> show pro) 1103 -- traceM ("\t" <> show (numArgs, numVars)) 1104 -- traceM ("\t" <> show (toList args)) 1105 let err = error ("UNINITIALIZED" <> show exePro.prgrm) 1106 vs <- newSmallArray (numVars + 1) err 1107 -- TODO: Figure out why this is wrong!! This is no good! 1108 go vs exePro.prgrm 1109 where 1110 go :: SmallMutableArray RealWorld Fan -> Run -> IO Fan 1111 go vs = \case 1112 CNS v -> pure v 1113 ARG 0 -> pure self -- TODO Does this still need to be special-cased? 1114 ARG i -> indexSmallArrayM args i 1115 VAR i -> readSmallArray vs i 1116 KAL xs -> do 1117 -- traceM "KAL" 1118 cs <- traverse (go vs) xs 1119 pure (appN cs) 1120 1121 LETREC binds b -> 1122 if sizeofSmallArray binds == 1 then do 1123 let (i, r) = binds .! 0 1124 rec res <- (writeSmallArray vs i res >> go vs r) 1125 go vs b 1126 else do 1127 rec for_ (zip [0..] $ toList binds) \(ix,(slot,_)) -> 1128 writeSmallArray vs slot (results .! ix) 1129 results <- for binds \(_,v) -> go vs v 1130 go vs b 1131 1132 LET i v b -> mdo 1133 -- traceM "LET" 1134 when (i < 0) do 1135 error "bad index" 1136 when (i >= sizeofSmallMutableArray vs) do 1137 error $ concat [ "out of bounds: " 1138 , show i 1139 , ">=" 1140 , show (sizeofSmallMutableArray vs) 1141 , "\n" 1142 , ppShow exePro 1143 ] 1144 go vs v >>= writeSmallArray vs i 1145 go vs b 1146 1147 PAR r xs -> do 1148 -- traceM "PAR" 1149 env <- traverse (go vs) xs 1150 pure (KLO r env) 1151 1152 -- TODO Maybe `trk` should take two arguments, name and data. 1153 TRK x b -> do 1154 xv <- go vs x 1155 evaluate (force xv) 1156 trk <- readIORef vTrkFan 1157 trk xv 1158 case trkName xv of 1159 Nothing -> go vs b 1160 Just (encodeUtf8 -> nm) -> 1161 withAlwaysTrace nm "trk" do 1162 res <- go vs b 1163 evaluate res 1164 1165 MK_ROW es -> do 1166 ROW . V.toArray <$> traverse (go vs) es 1167 1168 MK_TAB es -> do 1169 -- print ("mk_tab"::Text, res) 1170 TAb <$> traverse (go vs) es 1171 1172 EXE x sz (KLO _ e) xs -> do 1173 -- traceM "EXE_KLO" 1174 !buf <- newSmallArray sz (error "dur") 1175 let w = sizeofSmallArray e 1176 copySmallArray buf 0 e 0 w 1177 let !nar = sizeofSmallArray xs 1178 let fill i = unless (i==nar) do 1179 v <- go vs (xs.!i) 1180 writeSmallArray buf (i+w) v 1181 fill (i+1) 1182 fill 0 1183 env <- unsafeFreezeSmallArray buf 1184 pure (x env) 1185 1186 EXE x sz f xs -> do 1187 !buf <- newSmallArray sz f 1188 let !nar = sizeofSmallArray xs 1189 let fill i = unless (i==nar) do 1190 v <- go vs (xs.!i) 1191 writeSmallArray buf (i+1) v 1192 fill (i+1) 1193 fill 0 1194 env <- unsafeFreezeSmallArray buf 1195 pure (x env) 1196 1197 REC xs -> do 1198 let recArgs = length xs 1199 let recEnvSize = recArgs + 1 1200 !buf <- newSmallArray recEnvSize self 1201 let fill i = unless (i==recArgs) do 1202 v <- go vs (xs.!i) 1203 writeSmallArray buf (i+1) v 1204 fill (i+1) 1205 fill 0 1206 env <- unsafeFreezeSmallArray buf 1207 pure (executeLaw self recPro recPro env) 1208 1209 SEQ x b -> do 1210 -- traceM "SEQ" 1211 xv <- go vs x 1212 _ <- evaluate xv 1213 go vs b 1214 1215 IF_ i t e -> do 1216 -- traceM "IF_" 1217 go vs i >>= \case 1218 NAT 0 -> go vs e 1219 NAT _ -> go vs t 1220 _ -> go vs e 1221 1222 IFZ i t e -> do 1223 go vs i >>= \case 1224 NAT 0 -> go vs t 1225 _ -> go vs e 1226 1227 1228 SWI i f c -> do 1229 idx <- go vs i >>= \case 1230 NAT x -> pure $ fromIntegral x 1231 _ -> pure 0 1232 if idx >= sizeofSmallArray c 1233 then go vs f 1234 else go vs (c.!idx) 1235 1236 JMP i f c -> do 1237 key <- go vs i 1238 case lookup key c of 1239 Just x -> go vs x 1240 Nothing -> go vs f 1241 1242 -- TODO Rewrite `search` to use raw pointer manipulation. 1243 -- TODO Try to avoid the per-iteration bounds check by putting 1244 -- some sort of sentinal value at the end. 1245 JMP_WORD i f keyVec branches -> do 1246 go vs i >>= \case 1247 NAT (NatS# w) -> 1248 let 1249 !key = GHC.W# w 1250 !end = length keyVec 1251 1252 search ix | ix>=end = go vs f 1253 search ix | (keyVec SV.! ix == key) = go vs (branches.!ix) 1254 search ix = search (ix+1) 1255 in 1256 search 0 1257 _ -> 1258 go vs f 1259 1260 LAZ subroutine xs -> do 1261 let lazArgs = length xs 1262 !buf <- newSmallArray (lazArgs + 1) self 1263 let fill i = unless (i==lazArgs) do 1264 v <- go vs (xs.!i) 1265 writeSmallArray buf (i+1) v 1266 fill (i+1) 1267 fill 0 1268 env <- unsafeFreezeSmallArray buf 1269 1270 -- putStrLn "<LAZ>" 1271 -- pPrint ("self"::Text, self) 1272 -- pPrint ("prog"::Text, subroutine) 1273 -- pPrint ("envr"::Text, env) 1274 pure (executeLaw self recPro subroutine env) 1275 -- putStrLn "</LAZ>" 1276 -- pure res 1277 1278 OP2 _ f a b -> do 1279 af <- go vs a 1280 bf <- go vs b 1281 pure $ f af bf 1282 1283 trkName :: Fan -> Maybe Text 1284 trkName fan = do 1285 res <- case fan of 1286 NAT n -> either (const Nothing) pure (natUtf8 n) 1287 BAR n -> pure (decodeUtf8 n) 1288 ROW xs -> guard (not $ null xs) >> trkName (xs ! 0) 1289 _ -> Nothing 1290 guard (all C.isPrint res) 1291 pure res 1292 1293 -- WHAT EVEN ------------------------------------------------------------------- 1294 1295 fanIdx :: Nat -> Fan -> Fan 1296 fanIdx idxNat fan = 1297 if idxNat > fromIntegral (maxBound::Int) then 1298 -- We can't build structures big enough to index with non-int 1299 -- keys. 1300 0 1301 else 1302 go (fromIntegral idxNat) fan 1303 where 1304 go idx = \case 1305 ROW vec | idx < length vec -> vec ! idx 1306 TAb tab | idx < length tab -> if idxNat==0 then tabValsRow tab else 0 1307 KLO _ env -> idxKlo idx env 1308 _ -> 0 1309 1310 -- {{f 4 3} 2 1 0} 1311 idxKlo idx env = 1312 if arrIdx > 0 1313 then indexSmallArray env arrIdx 1314 else go (idx - (arrWid-1)) (indexSmallArray env 0) 1315 where 1316 arrWid = sizeofSmallArray env 1317 arrIdx = (arrWid - idx) - 1 1318 1319 op2Table :: Map Hash256 (String, (Fan -> Fan -> Fan)) 1320 op2Table = mapFromList 1321 [ ( idxHash, ("idx", op2Idx) ) 1322 , ( getHash, ("get", op2Get) ) 1323 , ( addHash, ("add", op2Add) ) 1324 , ( subHash, ("sub", op2Sub) ) 1325 , ( mulHash, ("mul", op2Mul) ) 1326 , ( eqlHash, ("eql", op2Eql) ) 1327 , ( lteHash, ("lte", op2Lte) ) 1328 , ( lthHash, ("lth", op2Lth) ) 1329 , ( gteHash, ("gte", op2Gte) ) 1330 , ( gthHash, ("gth", op2Gth) ) 1331 ] 1332 1333 op2Idx :: Fan -> Fan -> Fan 1334 op2Idx a b = fanIdx (toNat a) b 1335 1336 op2Get :: Fan -> Fan -> Fan 1337 op2Get a b = fanIdx (toNat b) a 1338 1339 op2Add :: Fan -> Fan -> Fan 1340 op2Add a b = NAT $ toNat a + toNat b 1341 1342 op2Sub :: Fan -> Fan -> Fan 1343 op2Sub a b = 1344 let (x, y) = (toNat a, toNat b) 1345 in NAT (if y>x then 0 else (x-y)) 1346 1347 op2Mul :: Fan -> Fan -> Fan 1348 op2Mul a b = NAT $ toNat a * toNat b 1349 1350 op2Eql :: Fan -> Fan -> Fan 1351 op2Eql a b = fromBit (fastValEq a b) 1352 1353 op2Lte :: Fan -> Fan -> Fan 1354 op2Lte a b = fromBit (a <= b) 1355 1356 op2Lth :: Fan -> Fan -> Fan 1357 op2Lth a b = fromBit (a < b) 1358 1359 op2Gte :: Fan -> Fan -> Fan 1360 op2Gte a b = fromBit (a >= b) 1361 1362 op2Gth :: Fan -> Fan -> Fan 1363 op2Gth a b = fromBit (a > b)