@@ -5,9 +5,10 @@ module Nock (tar, hax, fas, cell, atom, Annotation (..), Noun, RawNoun (..)) whe
55import Control.DeepSeq (NFData, force)
66import Data.Bits
77import Data.Hashable
8+import GHC.Base
89import GHC.Conc (par)
910import GHC.Generics (Generic)
10−import Numeric.Natural
11+import GHC.Num
1112
1213newtype Annotation = Annotation
1314 { hash :: Int
@@ -86,22 +87,38 @@ lus ~(Atom nat _) = atom (nat + 1)
8687tis :: Noun -> Noun -> Noun
8788tis lhs rhs = if hashEq lhs rhs then sig else one
8889
89−fas :: Natural -> Noun -> Noun
90−fas lhs rhs =
90+fasWord :: Word# -> Noun -> Noun
91+fasWord lhs rhs =
9192 case lhs of
92− 1 -> rhs
93− 2 -> case rhs of
93+ 1## -> rhs
94+ 2## -> case rhs of
9495 ~(Cell lhs' _ _) -> lhs'
95− 3 -> case rhs of
96+ 3## -> case rhs of
9697 ~(Cell _ rhs' _) -> rhs'
9798 n ->
98− let rest = fas (unsafeShiftR n 1) rhs
99− in if testBit n 0
100− then fas 3 rest
101− else fas 2 rest
99+ let rest = fasWord (uncheckedShiftRL# n 1#) rhs
100+ in case and# 1## n of
101+ 1## -> fasWord 3## rest
102+ _ -> fasWord 2## rest
103+
104+fas :: Natural -> Noun -> Noun
105+fas (NS w) rhs = fasWord w rhs
106+fas n rhs =
107+ let rest = fas (unsafeShiftR n 1) rhs
108+ in if testBit n 0
109+ then fas 3 rest
110+ else fas 2 rest
111+
112+haxWord :: Word# -> Noun -> Noun -> Noun
113+haxWord 1## newValue _ = newValue
114+haxWord place newValue ~(Cell lhs rhs _) =
115+ let a = uncheckedShiftRL# place 1#
116+ in case and# place 1## of
117+ 1## -> cell (haxWord a newValue lhs) rhs
118+ _ -> cell lhs (haxWord a newValue rhs)
102119
103120hax :: Natural -> Noun -> Noun -> Noun
104−hax 1 newValue _ = newValue
121+hax (NS w) newValue rhs = haxWord w newValue rhs
105122hax place newValue ~(Cell lhs rhs _) =
106123 let a = unsafeShiftR place 1
107124 in if testBit place 0
@@ -115,30 +132,31 @@ tar' :: Noun -> Noun -> Noun -> Noun
115132tar' b c subject = case b of
116133 Cell x y _ -> case c of
117134 ~(Cell l k _) -> cell (tar' x y subject) (tar' l k subject)
118− Atom n _ -> case n of
119− 0 -> case c of
135+ Atom (NB _) _ -> undefined
136+ Atom (NS n) _ -> case n of
137+ 0## -> case c of
120138 ~(Atom nat _) -> fas nat subject
121− 1 -> c
122− 3 -> case c of
139+ 1## -> c
140+ 3## -> case c of
123141 ~(Cell l k _) -> wut $ tar' l k subject
124− 4 -> case c of
142+ 4## -> case c of
125143 ~(Cell l k _) -> lus $ tar' l k subject
126144 _ -> case c of
127145 ~(Cell x ~(Cell h j _) _) -> case n of
128− 2 -> case (tar' h j subject, x) of
146+ 2## -> case (tar' h j subject, x) of
129147 ~(~(Cell u v _), ~(Cell l k _)) -> tar' u v (tar' l k subject)
130− 5 -> case x of
148+ 5## -> case x of
131149 ~(Cell l k _) -> tis (tar' h j subject) (tar' l k subject)
132− 7 -> case x of
150+ 7## -> case x of
133151 ~(Cell l k _) -> tar' h j (tar' l k subject)
134− 8 -> case x of
152+ 8## -> case x of
135153 ~(Cell l k _) -> tar' h j (cell (tar' l k subject) subject)
136− 9 -> tar' two (cell sigOne (cell sig x)) (tar' h j subject)
137− 6 -> case tar' sig (tar' sig (tar' four (cell four x) subject) twoThree) (cell h j) of
154+ 9## -> tar' two (cell sigOne (cell sig x)) (tar' h j subject)
155+ 6## -> case tar' sig (tar' sig (tar' four (cell four x) subject) twoThree) (cell h j) of
138156 ~(Cell u v _) -> tar' u v subject
139− 10 -> case x of
157+ 10## -> case x of
140158 ~(Cell ~(Atom b' _) ~(Cell u v _) _) -> hax b' (tar' u v subject) (tar' h j subject)
141− 11 -> case x of
159+ 11## -> case x of
142160 Cell _ ~(Cell u v _) _ -> tar' sig three (cell (tar' u v subject) (tar' h j subject))
143161 Atom _ _ -> tar' h j subject
144− u -> error $ show u
162+ _ -> undefined