JetImpl.hs (52284B)
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 -- TODO: =VCHUNKS 6 7 {-# OPTIONS_GHC -Wall #-} 8 {-# OPTIONS_GHC -Werror #-} 9 {-# LANGUAGE UnboxedTuples #-} 10 11 module Fan.JetImpl (installJetImpls, jetImpls, doTrk, doTrkRex) where 12 13 import Control.Monad.ST 14 import Control.Parallel 15 import Data.Bits 16 import Data.Maybe 17 import Data.Sorted 18 import Data.Sorted.Search 19 import Fan.Convert 20 import Fan.Seed 21 import Fan.Eval 22 import Fan.Jets 23 import Fan.Hash (fanHash) 24 import Foreign.ForeignPtr 25 import Foreign.Storable 26 import PlunderPrelude 27 28 import Data.ByteString.Builder (byteString, toLazyByteString) 29 import Fan.FFI hiding (c_revmemcmp) 30 import Foreign.Marshal.Alloc (allocaBytes) 31 import Foreign.Ptr (castPtr) 32 import GHC.Exts (Word(..), int2Word#, uncheckedIShiftL#, (+#)) 33 import Hash256 (hashToByteString) 34 import Loot.Backend (loadClosure) 35 import Loot.ReplExe (closureRex) 36 import Rex (GRex(..), RuneShape(..)) 37 import Unsafe.Coerce (unsafeCoerce) 38 39 import qualified Data.ByteString as BS 40 import qualified Data.ByteString.Unsafe as BS 41 import qualified Data.Vector as V 42 import qualified Fan.Prof as Prof 43 44 -------------------------------------------------------------------------------- 45 46 {- 47 Call this immediatly on executable startup. 48 -} 49 installJetImpls :: IO () 50 installJetImpls = writeIORef vJetImpl jetImpls 51 52 -------------------------------------------------------------------------------- 53 54 jetImpls :: Map Text (Maybe Jet) 55 jetImpls = mapFromList 56 [ ( "_Force" , Nothing ) 57 , ( "_Seq" , Just seqJet ) 58 , ( "_Trace" , Just traceJet ) 59 , ( "_DeepTrace" , Just deepTraceJet ) 60 , ( "_IsPin" , Nothing ) 61 , ( "_IsLaw" , Nothing ) 62 , ( "_IsApp" , Nothing ) 63 , ( "_IsNat" , Just isNatJet ) 64 , ( "_PlanTag" , Nothing ) 65 , ( "_PinItem" , Just pinItemJet ) 66 , ( "_LawArgs" , Nothing ) 67 , ( "_LawName" , Nothing ) 68 , ( "_LawBody" , Nothing ) 69 , ( "_Car" , Nothing ) 70 , ( "_Cdr" , Nothing ) 71 , ( "_Eqz" , Just eqzJet ) 72 , ( "_If" , Just ifJet ) 73 , ( "_Ifz" , Nothing ) 74 , ( "_Not" , Just notJet ) 75 , ( "_Bit" , Just bitJet ) 76 , ( "_And" , Just andJet ) 77 , ( "_Or" , Just orJet ) 78 , ( "_Xor" , Nothing ) 79 , ( "_Nand" , Nothing ) 80 , ( "_Nor" , Nothing ) 81 , ( "_Xnor" , Nothing ) 82 , ( "_ToNat" , Nothing ) 83 , ( "_Dec" , Just decJet ) 84 , ( "_Times" , Nothing ) 85 , ( "_Add" , Just addJet ) 86 , ( "_Mul" , Just mulJet ) 87 , ( "_Sub" , Just subJet ) 88 , ( "_Pow" , Nothing ) 89 , ( "_Bex" , Just bexJet ) 90 , ( "_OrdWeld" , Nothing ) 91 , ( "_Div" , Just divJet ) 92 , ( "_Mod" , Just modJet ) 93 , ( "_Lsh" , Just lshJet ) 94 , ( "_Rsh" , Just rshJet ) 95 , ( "_Bix" , Nothing ) 96 , ( "_Bitwise" , Nothing ) 97 , ( "_NatFold" , Nothing ) 98 , ( "_Dis" , Just disJet ) 99 , ( "_Con" , Just conJet ) 100 , ( "_Mix" , Just mixJet ) 101 , ( "_PopCount" , Nothing ) 102 , ( "_Met" , Just metJet ) 103 , ( "_Trunc" , Nothing ) 104 , ( "_BitSlice" , Nothing ) 105 , ( "_SetBit" , Nothing ) 106 , ( "_TestBit" , Nothing ) 107 , ( "_ClearBit" , Nothing ) 108 , ( "_Cmp" , Just cmpJet ) 109 , ( "_Eql" , Just eqlJet ) 110 , ( "_Neq" , Just neqJet ) 111 , ( "_Lth" , Just lthJet ) 112 , ( "_Lte" , Just lteJet ) 113 , ( "_Gth" , Just gthJet ) 114 , ( "_Gte" , Just gteJet ) 115 , ( "_Min" , Nothing ) 116 , ( "_Max" , Nothing ) 117 , ( "_Null" , Nothing ) 118 , ( "_Head" , Nothing ) 119 , ( "_Arity" , Nothing ) 120 , ( "_Len" , Just lenJet ) 121 , ( "_Put" , Just vputJet ) 122 , ( "_Get" , Just getJet ) 123 , ( "_Idx" , Just idxJet ) 124 , ( "_Mut" , Just vmutJet ) 125 , ( "_Last" , Nothing ) 126 , ( "_Switch" , Just vswitchJet ) 127 , ( "_Cow" , Nothing ) 128 , ( "_CowSize" , Nothing ) 129 , ( "_IsCow" , Nothing ) 130 , ( "_IsRow" , Nothing ) 131 , ( "_Gen" , Nothing ) 132 , ( "_Weld" , Just vweldJet ) 133 , ( "_Map" , Just vmapJet ) 134 , ( "_Rev" , Just vrevJet ) 135 , ( "rowCons" , Just vconsJet ) 136 , ( "rowSnoc" , Just vsnocJet ) 137 , ( "sum" , Just vsumJet ) 138 , ( "sumOf" , Just vsumOfJet ) 139 , ( "cat" , Just vcatJet ) 140 , ( "zip" , Just vzipJet ) 141 , ( "take" , Just vtakeJet ) 142 , ( "drop" , Just vdropJet ) 143 , ( "unfoldr" , Just unfoldrJet ) 144 , ( "_SizedListToRow" , Just sizedListToRowJet ) 145 , ( "_SizedListToRowRev" , Just sizedListToRowRevJet ) 146 , ( "bsearch" , Just bsearchJet ) 147 , ( "isDigit" , Just isDigitJet ) 148 , ( "implode" , Just implodeJet ) 149 , ( "_MkSet" , Nothing ) 150 , ( "_SetToRow" , Nothing ) 151 , ( "setSing" , Just setSingletonJet ) 152 , ( "setIsEmpty" , Just setIsEmptyJet ) 153 , ( "setLen" , Just setLenJet ) 154 , ( "setHas" , Just setHasJet ) 155 , ( "setMin" , Just setMinJet ) 156 , ( "setIns" , Just setInsJet ) 157 , ( "setDel" , Just setDelJet ) 158 , ( "setWeld" , Just setWeldJet ) 159 , ( "setCatRowAsc" , Just setCatRowAscJet ) 160 , ( "isSet" , Just isSetJet ) 161 , ( "setDrop" , Just setDropJet ) 162 , ( "setTake" , Just setTakeJet ) 163 , ( "setSplitAt" , Just setSplitAtJet ) 164 , ( "setIntersect" , Just setIntersectionJet ) 165 , ( "setSub" , Just setSubJet ) 166 , ( "setSplitLT" , Just setSplitLTJet ) 167 , ( "_MkTab" , Nothing ) 168 , ( "tabSing" , Just tabSingletonJet ) 169 , ( "isTab" , Just isTabJet ) 170 , ( "_TabKeys" , Just tabKeysSetJet ) 171 , ( "_TabVals" , Just tabValsJet ) 172 , ( "_TabKeysRow" , Just tabKeysRowJet ) 173 , ( "_TabKeysList" , Nothing ) 174 , ( "tabIdx" , Just tabIdxJet ) 175 , ( "tabElemIdx" , Just tabElemIdxJet ) 176 , ( "_TabLen" , Just tabLenJet ) 177 , ( "_TabIsEmpty" , Nothing ) 178 , ( "_TabHas" , Just tabHasKeyJet ) 179 , ( "_TabLookup" , Just tabLookupJet ) 180 , ( "tabIns" , Just tabInsJet ) 181 , ( "tabSwitch" , Just tabSwitchJet ) 182 , ( "tabToPairs" , Just tabToPairsJet ) 183 , ( "tabFromPairs" , Just tabFromPairsJet ) 184 , ( "tabToPairList" , Just tabToPairListJet ) 185 , ( "tabSplitAt" , Just tabSplitAtJet ) 186 , ( "tabSplitLT" , Just tabSplitLTJet ) 187 , ( "tabAlter" , Just tabAlterJet ) 188 , ( "tabMapWithKey" , Just tabMapWithKeyJet ) 189 , ( "tabMap" , Just tabMapJet ) 190 , ( "tabUnionWith" , Just tabUnionWithJet ) 191 , ( "tabWeld" , Just tabWeldJet ) 192 , ( "tabMinKey" , Just tabMinKeyJet ) 193 , ( "tabFoldlWithKey" , Just tabFoldlWithKeyJet ) 194 , ( "_TabFilterWithKey" , Nothing ) 195 , ( "padWeld" , Just padWeldJet ) 196 , ( "padCat" , Just padCatJet ) 197 , ( "padFlat" , Just padFlatJet ) 198 , ( "isBar" , Just isBarJet ) 199 , ( "_Bar" , Nothing ) 200 , ( "natBar" , Just natBarJet ) 201 , ( "barNat" , Just barNatJet ) 202 , ( "barLen" , Just barLenJet ) 203 , ( "barIsEmpty" , Just barIsEmptyJet ) 204 , ( "_NatToSizedBar" , Nothing ) 205 , ( "barIdx" , Just bIdxJet ) 206 , ( "barWeld" , Just barWeldJet ) 207 , ( "barCat" , Just barCatJet ) 208 , ( "barTake" , Just barTakeJet ) 209 , ( "barDrop" , Just barDropJet ) 210 , ( "_BarSliceToNat" , Nothing ) 211 , ( "barElemIndexEnd" , Just barElemIndexEndJet ) 212 , ( "barFlat" , Just barFlatJet ) 213 , ( "barElemIndexOff" , Just barElemIndex ) 214 , ( "par" , Just parJet ) 215 , ( "pseq" , Just pseqJet ) 216 , ( "w32" , Just w32Jet ) 217 , ( "add32" , Just add32Jet ) 218 , ( "mul32" , Just mul32Jet ) 219 , ( "div32" , Just div32Jet ) 220 , ( "and32" , Just and32Jet ) 221 , ( "or32" , Just or32Jet ) 222 , ( "xor32" , Just xor32Jet ) 223 , ( "lsh32" , Just lsh32Jet ) 224 , ( "rsh32" , Just rsh32Jet ) 225 , ( "sub32" , Just sub32Jet ) 226 , ( "ror32" , Just ror32Jet ) 227 , ( "rol32" , Just rol32Jet ) 228 , ( "w64" , Just w64Jet ) 229 , ( "add64" , Just add64Jet ) 230 , ( "mul64" , Just mul64Jet ) 231 , ( "div64" , Just div64Jet ) 232 , ( "and64" , Just and64Jet ) 233 , ( "or64" , Just or64Jet ) 234 , ( "xor64" , Just xor64Jet ) 235 , ( "lsh64" , Just lsh64Jet ) 236 , ( "rsh64" , Just rsh64Jet ) 237 , ( "sub64" , Just sub64Jet ) 238 , ( "ror64" , Just ror64Jet ) 239 , ( "rol64" , Just rol64Jet ) 240 , ( "iDiv64" , Just iDiv64Jet ) 241 , ( "_DataTag" , Just dataTagJet ) 242 , ( "_TypeTag" , Just typeTagJet ) 243 , ( "_TryExp" , Nothing ) 244 , ( "_Try" , Just tryJet ) 245 , ( "_Blake3" , Just blake3Jet ) 246 , ( "_PlanHash" , Just planHashJet ) 247 , ( "_PinHash" , Just pinHashJet ) 248 , ( "_LoadGerm" , Just loadGermJet ) 249 , ( "_SaveGerm" , Just saveGermJet ) 250 , ( "_LoadSeed" , Just loadSeedJet ) 251 , ( "_SaveSeed" , Just saveSeedJet ) 252 ] 253 254 -------------------------------------------------------------------------------- 255 256 ifJet :: Jet 257 ifJet _ env = if toBit(env.!1) then env.!2 else env.!3 258 259 isNatJet :: Jet 260 isNatJet _ env = 261 case env.!1 of 262 NAT{} -> NAT 1 263 _ -> NAT 0 264 265 eqlJet :: Jet 266 eqlJet _ env = 267 fromBit $ (fastValEq (env.!1) (env.!2)) 268 269 neqJet :: Jet 270 neqJet _ env = 271 fromBit $ not $ (fastValEq (env.!1) (env.!2)) 272 273 eqzJet :: Jet 274 eqzJet _ env = case env.!1 of 275 NAT 0 -> NAT 1 276 _ -> NAT 0 277 278 doTrkRex :: GRex Fan -> a -> a 279 doTrkRex rex val = unsafePerformIO do 280 trk <- readIORef vTrkRex 281 trk rex 282 evaluate val 283 284 doTrk :: Fan -> a -> a 285 doTrk msg val = unsafePerformIO do 286 trk <- readIORef vTrkFan 287 tag <- evaluate (force msg) 288 trk msg 289 290 case trkName tag of 291 Nothing -> evaluate val 292 Just (encodeUtf8 -> nm) -> 293 Prof.withAlwaysTrace nm "trk" do 294 evaluate val 295 296 -- TODO: (!greenOut (!(readIORef vShowFan) (env.!1))) probably needs to 297 -- be replaced with something like (!(readIORef vLogFan) LOG_TRK (env.!1)). 298 -- 299 -- This way the cog-machine can propery re-route this output to the 300 -- log-files. 301 traceJet :: Jet 302 traceJet _ env = doTrk (env.!1) (env.!2) 303 304 deepTraceJet :: Jet 305 deepTraceJet _ e = doTrkRex (planRexFull (e.!1)) (e.!2) 306 307 planRexFull :: Fan -> GRex a 308 planRexFull = fmap absurd . itemizeRexes . closureRex Nothing . loadClosure 309 where 310 itemizeRexes :: [GRex a] -> GRex a 311 itemizeRexes [x] = x 312 itemizeRexes rs = go rs 313 where 314 go [] = N OPEN "*" [] Nothing 315 go [x] = N OPEN "*" [x] Nothing 316 go (x:xs) = N OPEN "*" [x] (Just $ go xs) 317 318 {-# INLINE ordFan #-} 319 ordFan :: Ordering -> Nat 320 ordFan LT = 0 321 ordFan EQ = 1 322 ordFan GT = 2 323 324 cmpJet :: Jet 325 cmpJet _ env = NAT $ ordFan $ compare (env.!1) (env.!2) 326 327 lthJet :: Jet 328 lthJet _ env = if ((env.!1) < (env.!2)) then NAT 1 else NAT 0 329 330 gthJet :: Jet 331 gthJet _ env = if ((env.!1) > (env.!2)) then NAT 1 else NAT 0 332 333 lteJet :: Jet 334 lteJet _ env = if ((env.!1) <= (env.!2)) then NAT 1 else NAT 0 335 336 gteJet :: Jet 337 gteJet _ env = if ((env.!1) >= (env.!2)) then NAT 1 else NAT 0 338 339 bexJet :: Jet 340 bexJet _ env = NAT (bex $ toNat (env.!1)) 341 342 modJet :: Jet 343 modJet _ env = NAT (toNat(env.!1) `mod` toNat(env.!2)) 344 345 addJet :: Jet 346 addJet _ env = NAT (toNat(env.!1) + toNat(env.!2)) 347 348 lshJet :: Jet 349 lshJet _ env = 350 let xv = toNat(env.!1) 351 yv = toNat(env.!2) 352 in 353 if yv > maxInt 354 then error "TODO:lsh with huge offset" 355 else NAT (xv `shiftL` (fromIntegral yv :: Int)) 356 357 rshJet :: Jet 358 rshJet _ env = 359 let xv = toNat(env.!1) 360 yv = toNat(env.!2) 361 in 362 if yv > maxInt 363 then error "TODO: rsh with huge offset" 364 else NAT (xv `shiftR` (fromIntegral yv :: Int)) 365 366 metJet :: Jet 367 metJet _ env = 368 let x = toNat(env.!1) 369 in NAT $ natBitWidth x 370 371 pinItemJet :: Jet 372 pinItemJet _ env = 373 case env.!1 of 374 PIN p -> p.item 375 _ -> NAT 0 376 377 decJet :: Jet 378 decJet _ env = 379 case env.!1 of 380 NAT 0 -> NAT 0 381 NAT n -> NAT (n-1) 382 _ -> NAT 0 383 384 seqJet :: Jet 385 seqJet _ env = env.!1 `seq` env.!2 386 387 bitJet :: Jet 388 bitJet _ env = 389 case env.!1 of 390 NAT 0 -> NAT 0 391 NAT _ -> NAT 1 392 _ -> NAT 0 393 394 notJet :: Jet 395 notJet _ env = 396 case env.!1 of 397 NAT (NatS# 0##) -> NAT (NatS# 1##) 398 -- NAT (NatJ# (EXO 0 _)) -> error "invalid nat" 399 -- NAT (NatJ# (EXO 1 _)) -> error "invalid nat" 400 NAT _ -> NAT (NatS# 0##) 401 _ -> NAT 1 402 403 andJet :: Jet 404 andJet _ env = fromBit (toBit(env.!1) && toBit(env.!2)) 405 406 orJet :: Jet 407 orJet _ env = fromBit (toBit(env.!1) || toBit(env.!2)) 408 409 mulJet :: Jet 410 mulJet _ env = NAT (toNat(env.!1) * toNat(env.!2)) 411 412 mixJet :: Jet 413 mixJet _ env = NAT (toNat(env.!1) `xor` toNat(env.!2)) 414 415 conJet :: Jet 416 conJet _ env = NAT (toNat(env.!1) .&. toNat(env.!2)) 417 418 disJet :: Jet 419 disJet _ env = NAT (toNat(env.!1) .|. toNat(env.!2)) 420 421 divJet :: Jet 422 divJet _ env = 423 let yv = toNat (env.!2) 424 in if (yv == 0) 425 then NAT 0 426 else NAT (toNat(env.!1) `div` yv) 427 428 subJet :: Jet 429 subJet _ env = 430 let (x,y) = (toNat(env.!1), toNat(env.!2)) 431 in NAT (if y>x then 0 else (x-y)) 432 433 vcatJet :: Jet 434 vcatJet f env = orExec (f env) do 435 vs <- getRow (env.!1) 436 xs <- for vs getRow 437 pure $ ROW $ concat xs 438 439 vzipJet :: Jet 440 vzipJet f env = orExec (f env) do 441 as <- getRow (env.!1) 442 bs <- getRow (env.!2) 443 pure $ ROW $ rowZipWith v2 as bs 444 445 vrevJet :: Jet 446 vrevJet f env = orExec (f env) do 447 (ROW . rowReverse) <$> getRow (env.!1) 448 449 -- 450 -- TODO: What to do if given an unreasonable size here? PLAN code will 451 -- do something insane, but wont crash, this will crash. 452 -- 453 -- Maybe we should just fallback to unsized + check for very large sizes? 454 -- 455 sizedListToRow :: Int -> Fan -> Maybe (Array Fan) 456 sizedListToRow sz input = runST do 457 buf <- newArray sz (NAT 0) 458 let go _ (NAT 0) = Just <$> unsafeFreezeArray buf 459 go 0 _ = Just <$> unsafeFreezeArray buf 460 go n (ROW r) | length r == 2 = do writeArray buf (sz-n) (r!0) 461 go (n-1) (r!1) 462 go _ _ = pure Nothing 463 go sz input 464 465 sizedListToRowRev :: Int -> Fan -> Maybe (Array Fan) 466 sizedListToRowRev sz input = runST do 467 buf <- newArray sz (NAT 0) 468 let go _ (NAT 0) = Just <$> unsafeFreezeArray buf 469 go 0 _ = Just <$> unsafeFreezeArray buf 470 go i (ROW r) | length r == 2 = do writeArray buf (i-1) (r!0) 471 go (i-1) (r!1) 472 go _ _ = pure Nothing 473 go sz input 474 475 sizedListToRowJet :: Jet 476 sizedListToRowJet f env = 477 orExec (f env) do 478 sz <- case (env .! 1) of 479 NAT sz | sz <= maxInt -> pure (fromIntegral sz) 480 _ -> Nothing 481 rw <- sizedListToRow sz (env .! 2) 482 pure (ROW rw) 483 484 sizedListToRowRevJet :: Jet 485 sizedListToRowRevJet f env = 486 orExec (f env) do 487 sz <- case (env .! 1) of 488 NAT sz | sz <= maxInt -> pure (fromIntegral sz) 489 _ -> Nothing 490 rw <- sizedListToRowRev sz (env .! 2) 491 pure (ROW rw) 492 493 unfoldrJet :: Jet 494 unfoldrJet f env = orExecTrace "unfoldr" (f env) 495 (ROW . V.toArray <$> V.unfoldrM build (env.!2)) 496 where 497 fun = env.!1 498 build val = fromNoun @(Maybe (Fan, Fan)) (fun %% val) 499 500 bsearchJet :: Jet 501 bsearchJet f env = orExecTrace "bsearch" (f env) do 502 row <- getRow (env.!2) 503 let !(# idx, found #) = bsearch_ (env.!1) row 0 (sizeofArray row) 504 pure $ NAT $ NatS# (int2Word# ((idx `uncheckedIShiftL#` 1#) +# found)) 505 506 -- TODO Just don't do this, use bars instead of rows of bytes. 507 -- 508 -- We don't accept 0 bytes, since their behavior in the plunder 509 -- implementation is weird (silently dropped) 510 -- 511 -- TODO Converting from a vector to a list to a bytestring to an atom 512 -- is stupid we should directly implement `Vector U8 -> Nat`. 513 implodeJet :: Jet 514 implodeJet f env = orExec (f env) $ do 515 vs <- getRow (env.!1) 516 bs <- for vs \case 517 (NAT n) | n>0 && n<256 -> Just (fromIntegral n) 518 _ -> Nothing 519 pure $ NAT $ bytesNat $ pack $ toList bs 520 521 barDropJet :: Jet 522 barDropJet f env = orExec (f env) $ do 523 let n = toNat (env.!1) 524 b <- getBar (env.!2) 525 pure $ BAR $ 526 if (n >= fromIntegral (length b)) -- Prevent Int overflow 527 then mempty 528 else drop (fromIntegral n) b 529 530 barTakeJet :: Jet 531 barTakeJet f env = orExec (f env) $ do 532 let n = toNat (env.!1) 533 b <- getBar (env.!2) 534 535 pure $ BAR $ 536 if (n >= fromIntegral (length b)) -- Prevent Int overflow 537 then b 538 else take (fromIntegral n) b 539 540 barLenJet :: Jet 541 barLenJet f env = orExec (f env) $ do 542 b <- getBar (env.!1) 543 pure $ NAT $ fromIntegral $ length b 544 545 natBarJet :: Jet 546 natBarJet _ env = BAR $ natBytes $ toNat(env.!1) 547 548 barNatJet :: Jet 549 barNatJet f e = orExec (f e) $ do 550 b <- getBar (e.!1) 551 pure $ NAT $ bytesNat b 552 553 barIsEmptyJet :: Jet 554 barIsEmptyJet f e = orExec (f e) $ do 555 b <- getBar (e.!1) 556 pure $ fromBit $ null b 557 558 idxJet, getJet :: Jet 559 idxJet _ env = fanIdx (toNat (env.!1)) (env.!2) 560 getJet _ env = fanIdx (toNat (env.!2)) (env.!1) 561 562 -- Number of arguments applied to head. 563 fanLength :: Fan -> Int 564 fanLength = \case 565 ROW x -> length x 566 KLO _ t -> fanLength (t.!0) + (sizeofSmallArray t - 1) 567 TAb{} -> 1 -- always (keys args) 568 NAT{} -> 0 569 BAR{} -> 0 570 SET{} -> 0 571 FUN{} -> 0 572 PIN{} -> 0 573 COw{} -> 0 574 575 lenJet :: Jet 576 lenJet _ env = NAT $ fromIntegral $ fanLength (env.!1) 577 578 -- TODO: vsplice 579 580 vweldJet :: Jet 581 vweldJet f env = 582 orExec (f env) (vweld <$> getRow (env.!1) <*> getRow (env.!2)) 583 where 584 vweld :: Array Fan -> Array Fan -> Fan 585 vweld x y = ROW (x ++ y) 586 587 vmapJet :: Jet 588 vmapJet f env = 589 orExec (f env) (vmap (env.!1) <$> getRow (env.!2)) 590 where 591 vmap :: Fan -> Array Fan -> Fan 592 vmap fun vec = ROW $ fmap (fun %%) vec 593 594 vconsJet :: Jet 595 vconsJet f env = 596 orExec (f env) (vcons (env.!1) <$> getRow (env.!2)) 597 where 598 vcons :: Fan -> Array Fan -> Fan 599 vcons hed vec = ROW (rowCons hed vec) 600 601 vsnocJet :: Jet 602 vsnocJet f env = 603 orExec (f env) do 604 row <- getRow (env.!1) 605 pure (vmap row (env.!2)) 606 where 607 vmap :: Array Fan -> Fan -> Fan 608 vmap vec tel = ROW (rowSnoc vec tel) 609 610 vsumJet :: Jet 611 vsumJet f env = orExec (f env) (vsum <$> getRow (env.!1)) 612 where 613 vsum :: Array Fan -> Fan 614 vsum s = NAT $ foldr (\fan n -> n + toNat fan) 0 s 615 616 vsumOfJet :: Jet 617 vsumOfJet f env = 618 orExec (f env) (vsumOf (env.!1) <$> getRow (env.!2)) 619 where 620 vsumOf :: Fan -> Array Fan -> Fan 621 vsumOf fn s = NAT $ foldr (\fan n -> n + toNat (fn %% fan)) 0 s 622 623 -- TODO: vfind 624 625 -- [hed 3 2 1 0] 0 -> arr[5-(0+1)] -> arr[4] -> 0 626 -- [hed 3 2 1 0] 1 -> arr[5-(1+1)] -> arr[3] -> 1 627 -- [hed 3 2 1 0] 2 -> arr[5-(2+1)] -> arr[2] -> 2 628 -- [hed 3 2 1 0] 3 -> arr[5-(3+1)] -> arr[1] -> 3 629 630 -- {mutKlo} *ASSUMES* that the input is in bounds. 631 632 -- TODO: This is complicated because this runtime does not require 633 -- closures to be flat! In a native runtime, closures should just always 634 -- be kept flat. 635 636 mutKlo :: Int -> Fan -> Int -> SmallArray Fan -> Fan 637 mutKlo topKey v = \a xs -> unsafePerformIO (go topKey a xs) 638 where 639 go k a xs = do 640 let len = sizeofSmallArray xs 641 buf <- thawSmallArray xs 0 len 642 let args = len-1 643 if (k+1) < len then do 644 let ix = args - k 645 writeSmallArray buf ix v 646 KLO a <$> freezeSmallArray buf 0 len 647 else case xs.!0 of 648 -- If it's not here, it's in the head. So update the head, 649 -- and then re-create this node with that head. 650 KLO hedA hedXs -> do 651 newHead <- go (k - args) hedA hedXs 652 writeSmallArray buf 0 newHead 653 KLO a <$> freezeSmallArray buf 0 len 654 _ -> do 655 error "mutKlo: index out of bounds!" 656 657 doMut :: Fan -> Fan -> Fan -> Fan 658 doMut (toNat -> k) v x = case x of 659 _ | k > maxInt -> x 660 NAT{} -> x 661 PIN{} -> x 662 FUN{} -> x 663 BAR{} -> x 664 SET{} -> x 665 COw{} -> x 666 KLO a r -> if ki >= fanLength x then x else mutKlo ki v a r 667 TAb t -> if ki > 0 then x else SET (tabKeysSet t) %% v 668 ROW r -> if ki >= length r then x else ROW (rowPut ki v r) 669 where 670 ki = fromIntegral k :: Int 671 672 vputJet, vmutJet :: Jet 673 vputJet _ env = doMut (env.!2) (env.!3) (env.!1) 674 vmutJet _ env = doMut (env.!1) (env.!2) (env.!3) 675 676 -- Just jetting this so that it will show up "NOT MATCHED" if the hash 677 -- is wrong. 678 vswitchJet :: Jet 679 vswitchJet f env = 680 orExec (f env) (vtake (toNat (env.!1)) (env.!2) <$> getRow (env.!3)) 681 where 682 vtake :: Nat -> Fan -> Array Fan -> Fan 683 vtake i fb vec = 684 if (i >= fromIntegral (length vec)) 685 then fb 686 else vec ! fromIntegral i 687 688 vtakeJet :: Jet 689 vtakeJet f env = 690 orExec (f env) (vtake (toNat (env.!1)) <$> getRow (env.!2)) 691 where 692 vtake :: Nat -> Array Fan -> Fan 693 vtake n vec = 694 let siz = fromIntegral (length vec) 695 in ROW $ if (n >= siz) 696 then vec 697 else rowTake (fromIntegral n) vec 698 699 vdropJet :: Jet 700 vdropJet f env = 701 orExec (f env) (vdrop (toNat (env.!1)) <$> getRow (env.!2)) 702 where 703 vdrop :: Nat -> Array Fan -> Fan 704 vdrop n vec = 705 let siz = fromIntegral (length vec) 706 in ROW $ if (n >= siz) 707 then mempty 708 else rowDrop (fromIntegral n) vec 709 710 bIdxJet :: Jet 711 bIdxJet f env = 712 orExec (f env) (bidx (toNat (env.!1)) <$> getBar (env.!2)) 713 where 714 bidx :: Nat -> ByteString -> Fan 715 bidx n bs = 716 let siz = fromIntegral (length bs) 717 in NAT $ if (n >= siz) 718 then 0 719 else fromIntegral $ BS.index bs $ fromIntegral n 720 721 barCatJet :: Jet 722 barCatJet f env = 723 orExecTrace "barCat" (f env) $ do 724 vs <- getRow (env.!1) 725 bs <- traverse getBar vs 726 pure $ BAR $ concat bs 727 728 isBarJet :: Jet 729 isBarJet _ env = 730 case env.!1 of 731 BAR _ -> NAT 1 732 _ -> NAT 0 733 734 {- 735 TODO: Evaluate using `barTreeToList` for this. The algoritm isn't 736 exactly the same, but unclear if it's worse or better. Likely 737 consuming barTreeToList and using that explicitly fill a buffer would 738 be better than using Bytestring Builders, since we get none of the 739 usual advantages of that here. 740 741 If the approach indicated above is better, then this could probably 742 be simplified to something like (barCat . barTreeToList) with an 743 imperative implementation of barCat. 744 -} 745 barFlatJet :: Jet 746 barFlatJet _ env = 747 BAR $ toStrict $ toLazyByteString $ go $ (env.!1) 748 where 749 go (BAR b) = byteString b 750 go PIN{} = mempty -- pin 751 go COw{} = mempty -- law 752 go SET{} = mempty -- law 753 go FUN{} = mempty -- law 754 go (ROW r) = concat (go <$> r) -- app 755 go (TAb r) = concat (go <$> toList r) -- app 756 go k@KLO{} = concat (go <$> kloArgs k) -- app 757 go NAT{} = mempty -- nat 758 759 barTreeToList :: Fan -> [ByteString] 760 barTreeToList = \case 761 BAR b -> [b] -- law (but is a bar) 762 PIN{} -> [] -- pin (not an app) 763 COw{} -> [] -- law (not an app) 764 SET{} -> [] -- law (not an app) 765 FUN{} -> [] -- law (not an app) 766 ROW r -> concat (barTreeToList <$> toList r) -- app 767 TAb r -> concat (barTreeToList <$> toList r) -- app 768 k@KLO{} -> concat (barTreeToList <$> kloArgs k) -- app 769 NAT{} -> mempty -- nat 770 771 getInt :: Fan -> Maybe Int 772 getInt (NAT n) | n < maxInt = Just (fromIntegral n) 773 getInt _ = Nothing 774 775 -- TODO Is `BS.drop` O(n) now? 776 barElemIndex :: Jet 777 barElemIndex f env = 778 orExec (f env) (exe <$> getByte (env.!1) 779 <*> getInt (env.!2) 780 <*> getBar (env.!3)) 781 where 782 exe :: Word8 -> Int -> ByteString -> Fan 783 exe byte off bar = 784 NAT $ fromIntegral $ 785 case BS.elemIndex byte (drop off bar) of 786 Nothing -> length bar 787 Just ix -> ix+off 788 789 barElemIndexEndJet :: Jet 790 barElemIndexEndJet f env = 791 orExec (f env) (exe <$> getByte (env.!1) <*> getBar (env.!2)) 792 where 793 exe :: Word8 -> ByteString -> Fan 794 exe byte bar = case BS.elemIndexEnd byte bar of 795 Nothing -> NAT 0 796 Just ix -> (NAT 0) %% (NAT $ fromIntegral ix) 797 798 {- 799 padFlatFill :: Int -> UMVector Word -> [Nat] -> IO Fan 800 padFlatFill wordLength bufr = do 801 let go !used !idx !word [] = pure () 802 go !used !idx !word (x:xs) = do 803 let (used, word) = mix (used, word) x 804 805 if wordLength == 1 then 806 fromIntegral <$> peek bufr 807 else 808 _ 809 where 810 finalize :: (Int, Word) -> Word 811 finalize (used, acc) = 812 fromIntegral ((1 `shiftL` used) .|. acc) 813 814 mix :: (Int, Word) -> Nat -> (Int, Word) 815 mix (used, acc) (fromIntegral -> new) = 816 let 817 end = fromIntegral (wordBitWidth new) - 1 818 in 819 ( used + end 820 , acc .|. (clearBit new end `shiftL` used) 821 ) 822 823 padFlatJet :: Jet 824 padFlatJet _ e = 825 unsafePerformIO do 826 buf <- mallocBytes (8*wordWidth) 827 padFlatFill wordWidth buf (padFlatSeq arg) 828 where 829 arg = (e.!1) 830 831 bitWidth = 1 + padFlatBits arg 832 wordWidth = bitWidth `divUp` 64 833 divUp x y = (x `div` y) + (if x `mod` y == 0 then 0 else 1) 834 835 padFlatBits :: Fan -> Int 836 padFlatBits fan = sum ((\x -> natBitWidth x - 1) <$> padFlatSeq fan) 837 -} 838 839 -- TODO: Stub (finish implementing the much faster approach above) 840 padFlatJet :: Jet 841 padFlatJet _ e = pcat $ padFlatSeq (e.!1) 842 where 843 pcat vs = NAT $ foldl' padWeld 1 vs 844 845 padFlatSeq :: Fan -> [Nat] 846 padFlatSeq = 847 \top -> go top [] 848 where 849 go item acc = case item of 850 NAT 0 -> 1 : acc 851 NAT n -> n : acc 852 TAb xs -> foldr go acc (toList xs) 853 ROW xs -> foldr go acc (toList xs) 854 KLO _ x -> foldr go acc (drop 1 $ toList x) 855 _ -> 1 : acc 856 857 858 {- 859 p#111 p#110 -> p#111110 860 861 0b1111 0b1011 -> 0b1011111 862 863 (clearBit 3 0b1111) .|. (0b1011 << 3) 864 865 - where 3 is (bitWidth(0b1111) - 1) 866 867 -- TODO: This crashes if gen a zero input. 0 is not a valid pad, but 868 -- what should we do in this case? Abort and fallback to raw PLAN exe? 869 -} 870 padWeld :: Nat -> Nat -> Nat 871 padWeld x y = (x `clearBit` end) .|. (y `shiftL` end) 872 where 873 end :: Int 874 end = (natBitWidth x - 1) 875 876 isDigitJet :: Jet 877 isDigitJet _ e = 878 case (e.!1) of 879 NAT (NatS# xu) -> 880 let x = W# xu 881 in if x>=48 && x<=57 882 then NAT (NatS# 1##) 883 else NAT (NatS# 0##) 884 _ -> 885 NAT 0 886 887 toPad :: Fan -> Nat 888 toPad (NAT 0) = 1 889 toPad (NAT n) = n 890 toPad _ = 1 891 892 padWeldJet :: Jet 893 padWeldJet _ e = (NAT $ padWeld (toPad(e.!1)) (toPad(e.!2))) 894 895 -- TODO Do this using a mutable buffer (like in Jam) 896 padCatJet :: Jet 897 padCatJet f e = 898 orExecTrace "padCat" (f e) 899 (pcat <$> getRow (e.!1)) 900 where 901 pcat vs = NAT $ foldl' (\a i -> padWeld a (toPad i)) 1 vs 902 903 barWeldJet :: Jet 904 barWeldJet f e = 905 orExecTrace "barWeld" (f e) 906 (bweld <$> getBar (e.!1) <*> getBar (e.!2)) 907 where 908 bweld :: ByteString -> ByteString -> Fan 909 bweld a b = BAR (a <> b) 910 911 blake3Jet :: Jet 912 blake3Jet _ e = unsafePerformIO do 913 h <- c_jet_blake3_hasher_new 914 915 for_ (barTreeToList (e.!1)) \bar -> 916 BS.unsafeUseAsCStringLen bar \(byt, wid) -> 917 c_jet_blake3_hasher_update h (castPtr byt) (fromIntegral wid) 918 919 allocaBytes 32 $ \outbuf -> do 920 c_jet_blake3_hasher_finalize h (castPtr outbuf) 921 BAR <$> BS.packCStringLen (outbuf, 32) 922 923 planHashJet :: Jet 924 planHashJet _ e = BAR . hashToByteString . fanHash $ (e.!1) 925 926 pinHashJet :: Jet 927 pinHashJet _ e = case e.!1 of 928 PIN pin -> BAR $ hashToByteString pin.hash 929 _ -> NAT 0 930 931 tryJet :: Jet 932 tryJet f e = 933 case getRow (e.!1) of 934 Nothing -> f e 935 Just row -> case deepseq row (toList row) of 936 [] -> f e 937 x:xs -> unsafePerformIO do 938 try (evaluate $ force (foldl' (%%) x xs)) <&> \case 939 Left (PRIMOP_CRASH err val) -> toNoun (0::Nat, (err, val)) 940 Right vl -> toNoun (1::Nat, vl) 941 942 saveSeedJet :: Jet 943 saveSeedJet _ e = BAR $ unsafePerformIO $ saveSeed (e.!1) 944 945 loadSeedJet :: Jet 946 loadSeedJet f e = case e.!1 of 947 BAR b -> either (const $ f e) id $ unsafePerformIO $ loadSeed b 948 _ -> f e 949 950 -- Note that {_SaveGerm} returns 0 if given something besides a pin! 951 -- There's no need to fallback to the legal behavior in that case. 952 953 saveGermJet :: Jet 954 saveGermJet _ e = 955 case e.!1 of { PIN p -> save p; _ -> 0 } 956 where 957 save p = 958 let !bs = unsafePerformIO (saveGermPin p) 959 in toNoun (p.refs, bs) 960 961 -- TODO: This is a bad jet, because malformed input will cause fallback 962 -- to raw PLAN evaluation, which will be extremely slow. Need to have 963 -- error-behavior match between impl/jet so that the jet can also apply 964 -- to bad input. 965 966 loadGermJet :: Jet 967 loadGermJet f e = 968 fromMaybe (f e) do 969 refs <- getRowOf getPin (e.!1) 970 bytz <- getBar (e.!2) 971 unsafePerformIO do 972 loadGerm (V.fromArray refs) bytz >>= \case 973 Left{} -> pure Nothing 974 Right x -> Just . PIN <$> mkPin' x 975 976 setSingletonJet :: Jet 977 setSingletonJet _ e = SET $ ssetSingleton (e.!1) 978 979 isSetJet :: Jet 980 isSetJet _ e = 981 case (e.!1) of 982 SET{} -> NAT 1 983 _ -> NAT 0 984 985 setInsJet :: Jet 986 setInsJet f e = 987 orExecTrace "setIns" (f e) (i (e.!1) <$> getSet (e.!2)) 988 where 989 i :: Fan -> ArraySet Fan -> Fan 990 i n s = SET (insertSet n s) 991 992 setDelJet :: Jet 993 setDelJet f e = 994 orExecTrace "setDel" (f e) (d (e.!1) <$> getSet (e.!2)) 995 where 996 d :: Fan -> ArraySet Fan -> Fan 997 d n s = SET (deleteSet n s) 998 999 setMinJet :: Jet 1000 setMinJet f e = 1001 orExecTrace "setMin" (f e) (smin <$> getSet (e.!1)) 1002 where 1003 smin :: ArraySet Fan -> Fan 1004 smin s = case ssetLookupMin s of 1005 Nothing -> NAT 0 1006 Just m -> m 1007 1008 setLenJet :: Jet 1009 setLenJet f e = 1010 orExecTrace "setLen" (f e) (clen <$> getSet (e.!1)) 1011 where 1012 clen :: ArraySet Fan -> Fan 1013 clen = NAT . fromIntegral . length 1014 1015 setWeldJet :: Jet 1016 setWeldJet f e = 1017 orExecTrace "setWeld" (f e) (u <$> getSet (e.!1) <*> getSet (e.!2)) 1018 where 1019 u :: ArraySet Fan -> ArraySet Fan -> Fan 1020 u a b = SET (union a b) 1021 1022 setCatRowAscJet :: Jet 1023 setCatRowAscJet f e = orExecTrace "setCatRowAsc" (f e) do 1024 r <- getRow (e.!1) 1025 sets <- rowFilter (not . ssetIsEmpty) <$> traverse getSet r 1026 guard (isAsc $ toList sets) 1027 pure $ SET $ ssetFromDistinctAscList $ concat $ map toList sets 1028 where 1029 isAsc [] = True 1030 isAsc [_] = True 1031 isAsc (x:y:zs) = (ssetFindMax x < ssetFindMin y) && isAsc (y:zs) 1032 1033 1034 setHasJet :: Jet 1035 setHasJet f e = 1036 orExecTrace "setHas" (f e) (has (e.!1) <$> getSet (e.!2)) 1037 where 1038 has :: Fan -> ArraySet Fan -> Fan 1039 has n s = fromBit $ ssetMember n s 1040 1041 setTakeJet :: Jet 1042 setTakeJet f e = 1043 orExecTrace "setTake" (f e) (doTake (toNat(e.!1)) <$> getSet (e.!2)) 1044 where 1045 doTake :: Nat -> ArraySet Fan -> Fan 1046 doTake n s = SET (ssetTake (fromIntegral n) s) 1047 1048 setDropJet :: Jet 1049 setDropJet f e = 1050 orExecTrace "setDrop" (f e) (doDrop (toNat(e.!1)) <$> getSet (e.!2)) 1051 where 1052 doDrop :: Nat -> ArraySet Fan -> Fan 1053 doDrop n s = SET (ssetDrop (fromIntegral n) s) 1054 1055 setIsEmptyJet :: Jet 1056 setIsEmptyJet f e = 1057 orExecTrace "setIsEmpty" (f e) (doIs <$> getSet (e.!1)) 1058 where 1059 doIs :: ArraySet Fan -> Fan 1060 doIs s = fromBit $ ssetIsEmpty s 1061 1062 setSplitAtJet :: Jet 1063 setSplitAtJet f e = 1064 orExecTrace "setSplitAt" (f e) 1065 (doSplitAt (toNat(e.!1)) <$> getSet (e.!2)) 1066 where 1067 doSplitAt :: Nat -> ArraySet Fan -> Fan 1068 doSplitAt n s = let (a, b) = ssetSplitAt (fromIntegral n) s 1069 in ROW $ arrayFromList [SET a, SET b] 1070 1071 setSplitLTJet :: Jet 1072 setSplitLTJet f e = 1073 orExecTrace "setSplitLT" (f e) 1074 (doSplitLT (e.!1) <$> getSet (e.!2)) 1075 where 1076 doSplitLT :: Fan -> ArraySet Fan -> Fan 1077 doSplitLT n s = let (a, b) = ssetSpanAntitone (< n) s 1078 in ROW $ arrayFromListN 2 [SET a, SET b] 1079 1080 setIntersectionJet :: Jet 1081 setIntersectionJet f e = 1082 orExecTrace "setIntersection" (f e) 1083 (doIntersection <$> getSet (e.!1) <*> getSet (e.!2)) 1084 where 1085 doIntersection :: ArraySet Fan -> ArraySet Fan -> Fan 1086 doIntersection a b = SET (ssetIntersection a b) 1087 1088 setSubJet :: Jet 1089 setSubJet f e = 1090 orExecTrace "setSub" (f e) 1091 (doDifference <$> getSet (e.!1) <*> getSet (e.!2)) 1092 where 1093 doDifference :: ArraySet Fan -> ArraySet Fan -> Fan 1094 doDifference a b = SET (ssetDifference a b) 1095 1096 tabSingletonJet :: Jet 1097 tabSingletonJet _ e = TAb $ tabSingleton (e.!1) (e.!2) 1098 1099 isTabJet :: Jet 1100 isTabJet _ e = 1101 case (e.!1) of 1102 TAb{} -> NAT 1 1103 _ -> NAT 0 1104 1105 -- Just jetting this so that it will show up "NOT MATCHED" if the hash 1106 -- is wrong. 1107 tabSwitchJet :: Jet 1108 tabSwitchJet f e = 1109 orExecTrace "tabSwitch" (f e) (tswitch (e.!1) (e.!2) <$> getTab (e.!3)) 1110 where 1111 tswitch key fal tab = 1112 case lookup key tab of 1113 Just x -> x 1114 Nothing -> fal 1115 1116 tabIdxJet :: Jet 1117 tabIdxJet f e = 1118 orExecTrace "tabIdx" (f e) (tidx (e.!1) <$> getTab (e.!2)) 1119 where 1120 tidx k m = case tabLookup k m of 1121 Nothing -> NAT 0 1122 Just x -> x 1123 1124 tabInsJet :: Jet 1125 tabInsJet f e = 1126 orExecTrace "tabIns" (f e) (tmut (e.!1) (e.!2) <$> getTab (e.!3)) 1127 where 1128 tmut :: Fan -> Fan -> Tab Fan Fan -> Fan 1129 tmut k v t = TAb $ tabInsert k v t 1130 1131 tabElemIdxJet :: Jet 1132 tabElemIdxJet f e = 1133 orExecTrace "tabElemIdx" (f e) (telem (toNat(e.!1)) <$> getTab (e.!2)) 1134 where 1135 telem :: Nat -> Tab Fan Fan -> Fan 1136 telem i m = let n = fromIntegral i 1137 in if n >= tabSize m then NAT 0 1138 else let (k, v) = tabElemAt n m 1139 in ROW $ arrayFromListN 2 [k, v] 1140 1141 tabLenJet :: Jet 1142 tabLenJet f e = 1143 orExecTrace "tabLen" (f e) (tlen <$> getTab (e.!1)) 1144 where 1145 tlen :: Tab Fan Fan -> Fan 1146 tlen = NAT . fromIntegral . tabSize 1147 1148 tabToPairsJet :: Jet 1149 tabToPairsJet f e = 1150 orExecTrace "tabToPairs" (f e) (toP <$> getTab (e.!1)) 1151 where 1152 toP :: Tab Fan Fan -> Fan 1153 toP tab = ROW $ arrayFromListN (length tab) $ map v2' $ mapToList tab 1154 1155 tabToPairListJet :: Jet 1156 tabToPairListJet f e = 1157 orExecTrace "tabToPairList" (f e) (go . mapToList <$> getTab (e.!1)) 1158 where 1159 go [] = NAT 0 1160 go ((k,v):kvs) = v2 (v2 k v) (go kvs) 1161 1162 {-# INLINE v2 #-} 1163 v2 :: Fan -> Fan -> Fan 1164 v2 x y = ROW $ arrayFromListN 2 [x,y] 1165 1166 {-# INLINE v2' #-} 1167 v2' :: (Fan, Fan) -> Fan 1168 v2' (x,y) = ROW $ arrayFromListN 2 [x,y] 1169 1170 tabFromPairsJet :: Jet 1171 tabFromPairsJet f e = 1172 orExecTrace "tabFromPairs" (f e) (toP <$> getPairs (e.!1)) 1173 where 1174 toP :: [(Fan, Fan)] -> Fan 1175 toP = TAb . mapFromList 1176 1177 getPairs :: Fan -> Maybe [(Fan, Fan)] 1178 getPairs x = do 1179 row <- getRow x 1180 res <- traverse getPair row 1181 pure (toList res) 1182 1183 getPair :: Fan -> Maybe (Fan, Fan) 1184 getPair x = do 1185 vs <- getRow x 1186 guard (length vs == 2) 1187 Just (vs!0, vs!1) 1188 1189 tabLookupJet :: Jet 1190 tabLookupJet f e = 1191 orExecTrace "tabLookup" (f e) 1192 (doLookup (e.!1) <$> getTab (e.!2)) 1193 where 1194 doLookup :: Fan -> Tab Fan Fan -> Fan 1195 doLookup n t = case tabLookup n t of 1196 Nothing -> NAT 0 1197 Just fun -> NAT 0 %% fun 1198 1199 tabSplitAtJet :: Jet 1200 tabSplitAtJet f e = 1201 orExecTrace "tabSplitAt" (f e) 1202 (doSplitAt (toNat(e.!1)) <$> getTab(e.!2)) 1203 where 1204 doSplitAt :: Nat -> Tab Fan Fan -> Fan 1205 doSplitAt n s = let (a, b) = tabSplitAt (fromIntegral n) s 1206 in ROW $ arrayFromListN 2 [TAb a, TAb b] 1207 1208 tabSplitLTJet :: Jet 1209 tabSplitLTJet f e = 1210 orExecTrace "tabSplitLT" (f e) 1211 (doSplitLT (e.!1) <$> getTab (e.!2)) 1212 where 1213 doSplitLT :: Fan -> Tab Fan Fan -> Fan 1214 doSplitLT n s = let (a, b) = tabSpanAntitone (< n) s 1215 in ROW $ arrayFromListN 2 [TAb a, TAb b] 1216 1217 tabMapWithKeyJet :: Jet 1218 tabMapWithKeyJet f e = 1219 orExecTrace "tabMapWithKey" (f e) 1220 (doMap <$> (Just $ e.!1) <*> getTab (e.!2)) 1221 where 1222 doMap :: Fan -> Tab Fan Fan -> Fan 1223 doMap fun a = TAb $ tabMapWithKey (apply fun) a 1224 1225 apply :: Fan -> Fan -> Fan -> Fan 1226 apply fun k v = fun %% k %% v 1227 1228 tabMapJet :: Jet 1229 tabMapJet f e = 1230 orExecTrace "tabMap" (f e) (doMap (e.!1) <$> getTab (e.!2)) 1231 where 1232 doMap :: Fan -> Tab Fan Fan -> Fan 1233 doMap fun a = TAb $ tabMap (fun %%) a 1234 1235 tabUnionWithJet :: Jet 1236 tabUnionWithJet f e = 1237 orExecTrace "tabUnionWith" (f e) 1238 (doUnionWith <$> (Just $ e.!1) <*> getTab (e.!2) <*> getTab (e.!3)) 1239 where 1240 doUnionWith :: Fan -> Tab Fan Fan -> Tab Fan Fan -> Fan 1241 doUnionWith fun a b = TAb $ tabUnionWith (apply fun) a b 1242 1243 apply :: Fan -> Fan -> Fan -> Fan 1244 apply fun a b = fun %% a %% b 1245 1246 tabWeldJet :: Jet 1247 tabWeldJet f e = 1248 orExecTrace "tabWeldWith" (f e) 1249 (doUnionWith <$> getTab (e.!1) <*> getTab (e.!2)) 1250 where 1251 doUnionWith :: Tab Fan Fan -> Tab Fan Fan -> Fan 1252 doUnionWith a b = TAb (tabUnion a b) 1253 1254 tabMinKeyJet :: Jet 1255 tabMinKeyJet f e = 1256 orExecTrace "tabMin" (f e) (tmin <$> getTab (e.!1)) 1257 where 1258 tmin :: Tab Fan Fan -> Fan 1259 tmin s = case tabLookupMin s of 1260 Nothing -> NAT 0 1261 Just (k, _) -> k 1262 1263 tabFoldlWithKeyJet :: Jet 1264 tabFoldlWithKeyJet f e = 1265 orExecTrace "tabFoldlWithKey" (f e) $ do 1266 tab <- getTab $ e.!3 1267 let fun = e.!1 1268 initial = e.!2 1269 let wrapFun a k v = fun %% a %% k %% v 1270 pure $ tabFoldlWithKey' wrapFun initial tab 1271 1272 tabAlterJet :: Jet 1273 tabAlterJet f e = 1274 orExecTrace "tabAlter" (f e) (alt (e.!1) (e.!2) <$> getTab (e.!3)) 1275 where 1276 alt :: Fan -> Fan -> Tab Fan Fan -> Fan 1277 alt fun key m = TAb $ tabAlter (someAsMaybe . wrap fun) key m 1278 1279 -- Figuring this out is the next big thing 1280 wrap :: Fan -> Maybe Fan -> Fan 1281 wrap fun (Nothing) = fun %% NAT 0 1282 wrap fun (Just x) = fun %% (NAT 0 %% x) 1283 1284 someAsMaybe :: Fan -> Maybe Fan 1285 someAsMaybe = \case 1286 NAT _ -> Nothing 1287 x -> Just $ snd $ boom x 1288 1289 tabHasKeyJet :: Jet 1290 tabHasKeyJet f e = 1291 orExecTrace "tabHas" (f e) (hk (e.!1) <$> getTab(e.!2)) 1292 where 1293 hk :: Fan -> Tab Fan Fan -> Fan 1294 hk k m = case tabMember k m of 1295 False -> NAT 0 1296 True -> NAT 1 1297 1298 tabKeysRowJet :: Jet 1299 tabKeysRowJet f e = orExecTrace "_TabKeysRow" (f e) (tk <$> getTab(e.!1)) 1300 where 1301 tk :: Tab Fan Fan -> Fan 1302 tk = ROW . tabKeysArray 1303 1304 tabKeysSetJet :: Jet 1305 tabKeysSetJet f e = orExecTrace "_TabKeys" (f e) (tk <$> getTab(e.!1)) 1306 where 1307 tk :: Tab Fan Fan -> Fan 1308 tk = SET . tabKeysSet 1309 1310 tabValsJet :: Jet 1311 tabValsJet f e = orExecTrace "tabVals" (f e) (tv <$> getTab(e.!1)) 1312 where 1313 tv :: Tab Fan Fan -> Fan 1314 tv = ROW . tabElemsArray 1315 1316 typeTagJet :: Jet 1317 typeTagJet _ e = 1318 case (e.!1) of 1319 PIN{} -> 0 1320 FUN{} -> 1 1321 KLO{} -> 2 1322 NAT{} -> 3 1323 BAR{} -> 4 1324 ROW{} -> 5 1325 TAb{} -> 6 1326 COw{} -> 7 1327 SET{} -> 8 1328 1329 {- 1330 Returns either a nat, the first element of a closure (the last 1331 element applied), or 0 (for law/pin). 1332 1333 The (idx 0) of a tab is the values array. 1334 -} 1335 dataTagJet :: Jet 1336 dataTagJet _ e = 1337 let v = e.!1 in 1338 case v of 1339 ROW r -> if null r then 0 else (r!0) -- app 1340 KLO{} -> snd $ boom v -- app 1341 TAb{} -> snd $ boom v -- app 1342 PIN{} -> 0 -- pin 1343 FUN{} -> 0 -- law 1344 BAR{} -> 0 -- law 1345 COw{} -> 0 -- law 1346 SET{} -> 0 -- law 1347 NAT{} -> v 1348 1349 --------- 1350 -- w32 -- 1351 --------- 1352 1353 w32Jet :: Jet 1354 w32Jet _ env = 1355 NAT (fromIntegral . w32 $ toNat(env.!1)) 1356 1357 w32op :: (Word32 -> Word32 -> Word32) -> Jet 1358 w32op fun _ env = NAT $ fromIntegral $ fun (w32 $ toNat(env.!1)) (w32 $ toNat(env.!2)) 1359 1360 add32Jet,mul32Jet,div32Jet,sub32Jet,and32Jet,xor32Jet,or32Jet :: Jet 1361 add32Jet = w32op (+) 1362 mul32Jet = w32op (*) 1363 div32Jet = w32op (div) 1364 sub32Jet = w32op (-) 1365 and32Jet = w32op (.&.) 1366 xor32Jet = w32op xor 1367 or32Jet = w32op (.|.) 1368 1369 {-# INLINE w32opInt #-} 1370 w32opInt :: (Word32 -> Int -> Word32) -> Jet 1371 w32opInt fun _ env = 1372 NAT $ fromIntegral $ fun (w32 $ toNat (env.!1)) 1373 (fromIntegral $ w32 $ toNat (env.!2)) 1374 1375 lsh32Jet, rsh32Jet, ror32Jet, rol32Jet :: Jet 1376 rol32Jet = w32opInt rotateL 1377 lsh32Jet = w32opInt shiftL 1378 rsh32Jet = w32opInt shiftR 1379 ror32Jet = w32opInt rotateR 1380 1381 --------- 1382 -- w64 -- 1383 --------- 1384 1385 w64Jet :: Jet 1386 w64Jet _ env = 1387 NAT (fromIntegral . w64 $ toNat(env.!1)) 1388 1389 {-# INLINE w64op #-} 1390 w64op :: (Word64 -> Word64 -> Word64) -> Jet 1391 w64op fun _ env = NAT $ fromIntegral $ fun (w64 $ toNat(env.!1)) (w64 $ toNat(env.!2)) 1392 1393 add64Jet,mul64Jet,div64Jet,sub64Jet,and64Jet,xor64Jet,or64Jet :: Jet 1394 add64Jet = w64op (+) 1395 mul64Jet = w64op (*) 1396 div64Jet = w64op (div) 1397 sub64Jet = w64op (-) 1398 and64Jet = w64op (.&.) 1399 xor64Jet = w64op xor 1400 or64Jet = w64op (.|.) 1401 1402 {-# INLINE w64opInt #-} 1403 w64opInt :: (Word64 -> Int -> Word64) -> Jet 1404 w64opInt fun _ env = 1405 NAT $ fromIntegral $ fun (w64 $ toNat (env.!1)) 1406 (fromIntegral $ w64 $ toNat (env.!2)) 1407 1408 lsh64Jet, rsh64Jet, ror64Jet, rol64Jet :: Jet 1409 rol64Jet = w64opInt rotateL 1410 lsh64Jet = w64opInt shiftL 1411 rsh64Jet = w64opInt shiftR 1412 ror64Jet = w64opInt rotateR 1413 1414 --------- 1415 -- i64 -- 1416 --------- 1417 1418 i64op :: (Int64 -> Int64 -> Int64) -> Jet 1419 i64op fun _ env = NAT $ i64toNat $ fun (i64 $ toNat(env.!1)) (i64 $ toNat(env.!2)) 1420 1421 iDiv64Jet :: Jet 1422 iDiv64Jet = i64op (div) 1423 1424 parJet :: Jet 1425 parJet = unsafePerformIO do 1426 -- When law profiling is enabled, we disable `par` because actually trying to 1427 -- create sparks in the haskell interpreter screws up tracing. (par a b)=b is 1428 -- an entirely semantically valid definition of `par` and is what everything 1429 -- other than GHC does. 1430 Prof.lawProfilingEnabled >>= \case 1431 True -> pure \_ env -> env.!2 1432 False -> pure \_ env -> env.!1 `par` env.!2 1433 1434 pseqJet :: Jet 1435 pseqJet _ env = env.!1 `pseq` env.!2 1436 1437 -- Utils ----------------------------------------------------------------------- 1438 1439 toBit :: Fan -> Bool 1440 toBit (NAT 0) = False 1441 toBit (NAT _) = True 1442 toBit _ = False 1443 1444 fromBit :: Bool -> Fan 1445 fromBit True = NAT 1 1446 fromBit False = NAT 0 1447 1448 1449 -- w32 helpers 1450 bex32 :: Nat 1451 bex32 = 2 ^ (32::Nat) 1452 1453 _w32max :: Nat 1454 _w32max = bex32 - 1 1455 1456 maxInt :: Nat 1457 maxInt = fromIntegral (maxBound::Int) 1458 1459 w32 :: Nat -> Word32 1460 w32 x = fromIntegral (x `mod` bex32) 1461 1462 -- TODO: mod of 2^64 DOES NOT WORK!! Fix it. 1463 1464 w64 :: Nat -> Word64 1465 w64 (NatS# w) = wordToWord64 (W# w) 1466 w64 (NatJ# x) = wordToWord64 (unsafePerformIO $ withForeignPtr x.ptr peek) 1467 1468 -- TODO: Use unboxed. 1469 -- TODO: Explicit cast (they are identical on this arch) 1470 {-# INLINE wordToWord64 #-} 1471 wordToWord64 :: Word -> Word64 1472 wordToWord64 = unsafeCoerce 1473 1474 -- i64 helpers 1475 -- Int<->Word conversions preserve representation, not sign 1476 i64 :: Nat -> Int64 1477 i64 = fromIntegral . w64 1478 1479 i64toNat :: Int64 -> Nat 1480 i64toNat i = fromIntegral (fromIntegral i :: Word64) 1481 1482 bex :: Nat -> Nat 1483 bex n = 2 ^ n 1484 1485 getBar :: Fan -> Maybe ByteString 1486 getBar (BAR b) = Just b 1487 getBar _ = Nothing 1488 1489 getSet :: Fan -> Maybe (ArraySet Fan) 1490 getSet (SET c) = Just c 1491 getSet _ = Nothing 1492 1493 getTab :: Fan -> Maybe (Tab Fan Fan) 1494 getTab (TAb b) = Just b 1495 getTab _ = Nothing 1496 1497 orExec :: Fan -> Maybe Fan -> Fan 1498 orExec _ (Just r) = r 1499 orExec fb Nothing = fb 1500 1501 orExecTrace :: String -> Fan -> Maybe Fan -> Fan 1502 orExecTrace _ fb res = orExec fb res 1503 1504 -- orExecTrace msg xs res = case res of 1505 -- Nothing -> trace (msg <> ".nomatch") (orExec xs res) 1506 -- Just{} -> trace (msg <> ".match") (orExec xs res)