diff options
-rw-r--r-- | prototypes/LamMachineV2.hs | 257 |
1 files changed, 118 insertions, 139 deletions
diff --git a/prototypes/LamMachineV2.hs b/prototypes/LamMachineV2.hs index b0e9c9db..a9556888 100644 --- a/prototypes/LamMachineV2.hs +++ b/prototypes/LamMachineV2.hs | |||
@@ -23,8 +23,7 @@ import Data.Monoid | |||
23 | import Data.Maybe | 23 | import Data.Maybe |
24 | import Data.Bits | 24 | import Data.Bits |
25 | import Data.String | 25 | import Data.String |
26 | import qualified Vector as PV | 26 | import qualified Data.Vector as PV |
27 | import qualified Data.Vector as PV' | ||
28 | import qualified Data.Vector.Mutable as V | 27 | import qualified Data.Vector.Mutable as V |
29 | import qualified Data.Vector.Unboxed.Mutable as UV | 28 | import qualified Data.Vector.Unboxed.Mutable as UV |
30 | import qualified Data.Vector.Unboxed as PUV | 29 | import qualified Data.Vector.Unboxed as PUV |
@@ -65,50 +64,23 @@ instance VecLike (Vec s a) (ST s) where | |||
65 | type VElem (Vec s a) = a | 64 | type VElem (Vec s a) = a |
66 | 65 | ||
67 | new n | n < 0 = error $ "new: " ++ show n | 66 | new n | n < 0 = error $ "new: " ++ show n |
68 | new n = Vec 0 <$> V.new n | 67 | new n = Vec 0 <$> V.unsafeNew n |
69 | 68 | ||
70 | append (Vec n v) (k, xs) = do | 69 | append (Vec n v@(V.length -> m)) (k, xs) = do |
71 | v' <- myGrow_ v (n + k) | 70 | let !nk = n + k |
72 | sequence_ $ zipWith (V.write v') [n..] xs | 71 | v' <- if m >= nk then return v else V.unsafeGrow v (2 * nk - m) |
73 | return $ Vec (n + k) v' | 72 | zipWithM_ (V.unsafeWrite v') [n..] xs |
74 | where | 73 | return $ Vec nk v' |
75 | myGrow_ v@(V.length -> m) n | ||
76 | | m >= n = return v | ||
77 | | otherwise = V.grow v (2 * n - m) | ||
78 | |||
79 | read_ (Vec _ v) i = V.read v i | ||
80 | |||
81 | freezedRead (Vec _ v) = PV'.unsafeFreeze v <&> PV'.unsafeIndex | ||
82 | |||
83 | write x@(Vec _ v) i a = V.write v i a >> return x | ||
84 | |||
85 | modify x@(Vec _ v) i a = V.modify v a i >> return x | ||
86 | |||
87 | vToList (Vec n v) = mapM (V.read v) [0..n-1] | ||
88 | |||
89 | ----------------- | ||
90 | 74 | ||
91 | data PVec a = PVec !Int !(PV.V a) | 75 | read_ (Vec _ v) i = V.unsafeRead v i |
92 | 76 | ||
93 | instance HasLen (PVec a) where | 77 | freezedRead (Vec _ v) = PV.unsafeFreeze v <&> PV.unsafeIndex |
94 | len (PVec n _) = n | ||
95 | 78 | ||
96 | instance Monad m => VecLike (PVec a) m where | 79 | write x@(Vec _ v) i a = V.unsafeWrite v i a >> return x |
97 | type VElem (PVec a) = a | ||
98 | 80 | ||
99 | new n = return $ PVec 0 PV.Nil | 81 | modify x@(Vec _ v) i a = V.unsafeModify v a i >> return x |
100 | 82 | ||
101 | append (PVec n v) (k, xs) = return $ PVec (n + k) $ foldl (flip PV.Cons) v $ take k $ xs ++ repeat (error "yzv") | 83 | vToList (Vec n v) = mapM (V.unsafeRead v) [0..n-1] |
102 | |||
103 | read_ (PVec n v) i = return $ PV.index v (n - i - 1) | ||
104 | |||
105 | freezedRead (PVec n v) = return $ \i -> PV.index v (n - i - 1) | ||
106 | |||
107 | write v i x = modify v i $ const x | ||
108 | |||
109 | modify (PVec n v) i f = return $ PVec n $ PV.update v (n - i - 1) f | ||
110 | |||
111 | vToList (PVec _ a) = return $ reverse $ PV.toList a | ||
112 | 84 | ||
113 | --------------------------------------------------------------------------- data structures | 85 | --------------------------------------------------------------------------- data structures |
114 | 86 | ||
@@ -120,7 +92,6 @@ data Lit | |||
120 | 92 | ||
121 | data Exp | 93 | data Exp |
122 | = Var_ !DB | 94 | = Var_ !DB |
123 | -- | Free !Int | ||
124 | | Lam VarInfo Exp | 95 | | Lam VarInfo Exp |
125 | | App Exp Exp | 96 | | App Exp Exp |
126 | | Con ConIndex [Exp] | 97 | | Con ConIndex [Exp] |
@@ -151,19 +122,32 @@ pattern Int i = Lit (LInt i) | |||
151 | 122 | ||
152 | infixl 4 `App` | 123 | infixl 4 `App` |
153 | 124 | ||
154 | data EnvPiece e | 125 | data EnvPiece |
155 | = EApp e | 126 | = EApp !EExp |
156 | | ECase CaseInf [e] | 127 | | ECase CaseInf ![EExp] |
157 | | EDelta !Op [Lit] [e] | 128 | | EDelta !Op ![Lit] ![EExp] |
158 | | Update_ !DB | 129 | | Update_ !DB |
159 | deriving (Eq, Show, Functor) | 130 | deriving (Eq, Show) |
160 | 131 | ||
161 | data HNF e | 132 | data HNF |
162 | = HLam VarInfo e | 133 | = HLam VarInfo !EExp |
163 | | HCon ConIndex [DB] | 134 | | HCon ConIndex ![DB] |
164 | | HLit !Lit | 135 | | HLit !Lit |
165 | | HVar_ !DB | 136 | | HVar_ !DB |
166 | deriving (Eq, Show, Functor) | 137 | | HPiece !EnvPiece !HNF |
138 | | HLet !Int ![EExp] !HNF | ||
139 | deriving (Eq, Show) | ||
140 | |||
141 | zipWith' f (x: xs) (y: ys) = f x y !: zipWith' f xs ys | ||
142 | zipWith' _ _ _ = [] | ||
143 | {- | ||
144 | f <$!> [] = [] | ||
145 | f <$!> (a: as) = f a :! (f <$!> as) | ||
146 | -} | ||
147 | a !: as = a `seq` as `seq` (a: as) | ||
148 | |||
149 | [] ++! xs = xs | ||
150 | (x: xs) ++! ys = x !: (xs ++! ys) | ||
167 | 151 | ||
168 | pattern Update i = Update_ (Pos i) | 152 | pattern Update i = Update_ (Pos i) |
169 | 153 | ||
@@ -183,20 +167,18 @@ pattern Pos i <- (getPos -> Just i) | |||
183 | getPos i | i >= 0 = Just i | 167 | getPos i | i >= 0 = Just i |
184 | getPos _ = Nothing | 168 | getPos _ = Nothing |
185 | 169 | ||
186 | |||
187 | data EExp | 170 | data EExp |
188 | = ExpC !Int [EExp] [EnvPiece EExp] (HNF EExp) | 171 | = ExpC !Int ![EExp] !HNF |
189 | | ErrExp | 172 | | ErrExp |
190 | deriving (Eq, Show) | 173 | deriving (Eq, Show) |
191 | 174 | ||
192 | pattern PExp ps e <- ExpC 0 _ ps e | 175 | pattern SExp :: HNF -> EExp |
193 | where PExp = ExpC 0 [] | 176 | pattern SExp e <- ExpC 0 _ e |
194 | 177 | where SExp = ExpC 0 [] | |
195 | pattern SExp e = PExp [] e | ||
196 | 178 | ||
197 | pattern ERef r = SExp (HVar_ r) | 179 | pattern ERef r = SExp (HVar_ r) |
198 | 180 | ||
199 | pattern LExp n ls v = ExpC n ls [] (HVar_ v) | 181 | pattern LExp n ls v = ExpC n ls (HVar_ v) |
200 | 182 | ||
201 | -------------------------------------- max db index | 183 | -------------------------------------- max db index |
202 | 184 | ||
@@ -213,30 +195,31 @@ class Rearrange a where | |||
213 | rearrange :: (Int -> Int) -> Int -> a -> a | 195 | rearrange :: (Int -> Int) -> Int -> a -> a |
214 | 196 | ||
215 | instance Rearrange a => Rearrange [a] where | 197 | instance Rearrange a => Rearrange [a] where |
216 | rearrange f i = map (rearrange f i) | 198 | rearrange f i xs = rearrange f i <$!> xs |
217 | 199 | ||
218 | instance Rearrange EExp | 200 | instance Rearrange EExp |
219 | where | 201 | where |
220 | rearrange _ _ ErrExp = ErrExp | 202 | rearrange _ _ ErrExp = ErrExp |
221 | rearrange f l_ (ExpC n ls ps e) = ExpC n (rearrange f l ls) (rearrange f l ps) $ rearrange f l e | 203 | rearrange f l_ (ExpC n ls e) = ExpC n (rearrange f l ls) $ rearrange f l e |
222 | where | 204 | where |
223 | l = l_ + n | 205 | l = l_ + n |
224 | 206 | ||
225 | instance Rearrange e => Rearrange (EnvPiece e) | 207 | instance Rearrange EnvPiece |
226 | where | 208 | where |
227 | rearrange f l = \case | 209 | rearrange f l = \case |
228 | EApp e -> EApp $ rearrange f l e | 210 | EApp e -> EApp $ rearrange f l e |
229 | ECase is@(_, i) es -> ECase is $ zipWith (rearrange f . (l +)) i es | 211 | ECase is@(_, i) es -> ECase is $ zipWith' (rearrange f . (l +)) i es |
230 | EDelta o ls es -> EDelta o ls $ rearrange f l es | 212 | EDelta o ls es -> EDelta o ls $ rearrange f l es |
231 | Update_ i -> Update_ $ atL f l i | 213 | Update_ i -> Update_ $ atL f l i |
232 | 214 | ||
233 | instance Rearrange e => Rearrange (HNF e) | 215 | instance Rearrange HNF |
234 | where | 216 | where |
235 | rearrange f l = \case | 217 | rearrange f l = \case |
236 | HLam i e -> HLam i $ rearrange f (l+1) e | 218 | HLam i e -> HLam i $ rearrange f (l+1) e |
237 | HCon i ns -> HCon i $ atL f l <$> ns | 219 | HCon i ns -> HCon i $ atL f l <$!> ns |
238 | HVar_ i -> HVar_ $ atL f l i | 220 | HVar_ i -> HVar_ $ atL f l i |
239 | x -> x | 221 | HPiece p e -> HPiece (rearrange f l p) $ rearrange f l e |
222 | x@HLit{} -> x | ||
240 | 223 | ||
241 | instance Rearrange Exp | 224 | instance Rearrange Exp |
242 | where | 225 | where |
@@ -249,14 +232,6 @@ instance Rearrange Exp | |||
249 | Delta d es -> Delta d $ rearrange f l es | 232 | Delta d es -> Delta d $ rearrange f l es |
250 | x -> x | 233 | x -> x |
251 | 234 | ||
252 | {- | ||
253 | instance (Rearrange a, Rearrange b) => Rearrange (a, b) where | ||
254 | rearrange f i (a, b) = (rearrange f i a, rearrange f i b) | ||
255 | |||
256 | instance Rearrange (Info a) where | ||
257 | rearrange _ _ = id | ||
258 | -} | ||
259 | |||
260 | ---------- | 235 | ---------- |
261 | 236 | ||
262 | rearrange' f = rearrange f 0 | 237 | rearrange' f = rearrange f 0 |
@@ -288,9 +263,9 @@ instance FVs a => FVs [a] where | |||
288 | fv l f [] = return | 263 | fv l f [] = return |
289 | fv l f (x: xs) = fv l f x >=> fv l f xs | 264 | fv l f (x: xs) = fv l f x >=> fv l f xs |
290 | 265 | ||
291 | sfv f = map . sfv f | 266 | sfv l f xs = sfv l f <$!> xs |
292 | 267 | ||
293 | open f = map . open f | 268 | open l f xs = open l f <$!> xs |
294 | 269 | ||
295 | instance (FVs a, FVs b) => FVs (a, b) where | 270 | instance (FVs a, FVs b) => FVs (a, b) where |
296 | fv l f (a, b) = fv l f a >=> fv l f b | 271 | fv l f (a, b) = fv l f a >=> fv l f b |
@@ -301,18 +276,18 @@ instance (FVs a, FVs b) => FVs (a, b) where | |||
301 | 276 | ||
302 | instance FVs EExp where | 277 | instance FVs EExp where |
303 | fv f l ErrExp = return | 278 | fv f l ErrExp = return |
304 | fv f l (ExpC n ls ps e) = fv f l' ls >=> fv f l' ps >=> fv f l' e | 279 | fv f l (ExpC n ls e) = fv f l' ls >=> fv f l' e |
305 | where l' = l + n | 280 | where l' = l + n |
306 | 281 | ||
307 | sfv f l ErrExp = ErrExp | 282 | sfv f l ErrExp = ErrExp |
308 | sfv f l (ExpC n ls ps e) = ExpC n (sfv f l' ls) (sfv f l' ps) (sfv f l' e) | 283 | sfv f l (ExpC n ls e) = ExpC n (sfv f l' ls) (sfv f l' e) |
309 | where l' = l + n | 284 | where l' = l + n |
310 | 285 | ||
311 | open f l ErrExp = ErrExp | 286 | open f l ErrExp = ErrExp |
312 | open f l (ExpC n ls ps e) = ExpC n (open f l' ls) (open f l' ps) (open f l' e) | 287 | open f l (ExpC n ls e) = ExpC n (open f l' ls) (open f l' e) |
313 | where l' = l + n | 288 | where l' = l + n |
314 | 289 | ||
315 | instance FVs e => FVs (EnvPiece e) where | 290 | instance FVs EnvPiece where |
316 | 291 | ||
317 | fv f l = \case | 292 | fv f l = \case |
318 | EApp e -> fv f l e | 293 | EApp e -> fv f l e |
@@ -322,34 +297,37 @@ instance FVs e => FVs (EnvPiece e) where | |||
322 | 297 | ||
323 | sfv f l = \case | 298 | sfv f l = \case |
324 | EApp e -> EApp $ sfv f l e | 299 | EApp e -> EApp $ sfv f l e |
325 | ECase is@(_, i) es -> ECase is $ zipWith (sfv f . (l +)) i es | 300 | ECase is@(_, i) es -> ECase is $ zipWith' (sfv f . (l +)) i es |
326 | EDelta o ls es -> EDelta o ls $ sfv f l es | 301 | EDelta o ls es -> EDelta o ls $ sfv f l es |
327 | Update_ i -> Update_ $ atL f l i | 302 | Update_ i -> Update_ $ atL f l i |
328 | 303 | ||
329 | open f l = \case | 304 | open f l = \case |
330 | EApp e -> EApp $ open f l e | 305 | EApp e -> EApp $ open f l e |
331 | ECase is@(_, i) es -> ECase is $ zipWith (open f . (l +)) i es | 306 | ECase is@(_, i) es -> ECase is $ zipWith' (open f . (l +)) i es |
332 | EDelta o ls es -> EDelta o ls $ open f l es | 307 | EDelta o ls es -> EDelta o ls $ open f l es |
333 | Update_ i -> Update_ $ openL f l i | 308 | Update_ i -> Update_ $ openL f l i |
334 | 309 | ||
335 | instance FVs e => FVs (HNF e) where | 310 | instance FVs HNF where |
336 | 311 | ||
337 | fv f l = \case | 312 | fv f l = \case |
338 | HLam i e -> fv f (l+1) e | 313 | HLam i e -> fv f (l+1) e |
339 | HCon i ns -> foldr (>=>) return $ map (addI f l) ns | 314 | HCon i ns -> foldr (>=>) return $ addI f l <$!> ns |
340 | HVar_ i -> addI f l i | 315 | HVar_ i -> addI f l i |
316 | HPiece p e -> fv f l p >=> fv f l e | ||
341 | HLit{} -> return | 317 | HLit{} -> return |
342 | 318 | ||
343 | sfv f l = \case | 319 | sfv f l = \case |
344 | HLam i e -> HLam i $ sfv f (l+1) e | 320 | HLam i e -> HLam i $ sfv f (l+1) e |
345 | HCon i ns -> HCon i $ atL f l <$> ns | 321 | HCon i ns -> HCon i $ atL f l <$!> ns |
346 | HVar_ i -> HVar_ $ atL f l i | 322 | HVar_ i -> HVar_ $ atL f l i |
323 | HPiece p e -> HPiece (sfv f l p) $ sfv f l e | ||
347 | x@HLit{} -> x | 324 | x@HLit{} -> x |
348 | 325 | ||
349 | open f l = \case | 326 | open f l = \case |
350 | HLam i e -> HLam i $ open f (l+1) e | 327 | HLam i e -> HLam i $ open f (l+1) e |
351 | HCon i ns -> HCon i $ openL f l <$> ns | 328 | HCon i ns -> HCon i $ openL f l <$!> ns |
352 | HVar_ i -> HVar_ $ openL f l i | 329 | HVar_ i -> HVar_ $ openL f l i |
330 | HPiece p e -> HPiece (open f l p) $ open f l e | ||
353 | x@HLit{} -> x | 331 | x@HLit{} -> x |
354 | 332 | ||
355 | openL f l (Neg i) | i >= f = i - f + l | 333 | openL f l (Neg i) | i >= f = i - f + l |
@@ -384,24 +362,24 @@ preprocess = \case | |||
384 | Lit l -> SExp $ HLit l | 362 | Lit l -> SExp $ HLit l |
385 | Var_ i -> SExp $ HVar_ i | 363 | Var_ i -> SExp $ HVar_ i |
386 | Lam i e -> SExp $ HLam i $ hnf e | 364 | Lam i e -> SExp $ HLam i $ hnf e |
387 | Y s e -> ExpC (n+1) (ls ++ [({-s,-} PExp ps f)]) mempty (HVar n) | 365 | Y s e -> ExpC (n+1) (ls ++ [({-s,-} SExp f)]) (HVar n) |
388 | where ExpC n ls ps f = hnf e | 366 | where ExpC n ls f = hnf e |
389 | Delta d (e: es) -> add' (EDelta d [] $ preprocess <$> es) $ preprocess e | 367 | Delta d (e: es) -> add' (EDelta d [] $ preprocess <$!> es) $ preprocess e |
390 | App e f -> add' (EApp $ letify "u" $ preprocess f) $ preprocess e | 368 | App e f -> add' (EApp $ letify "u" $ preprocess f) $ preprocess e |
391 | Case is@(_, i) e es -> add' (ECase is $ zipWith (\ns -> if ns == 0 then preprocess else hnf) i es) $ preprocess e | 369 | Case is@(_, i) e es -> add' (ECase is $ zipWith' (\ns -> if ns == 0 then preprocess else hnf) i es) $ preprocess e |
392 | Con i es -> foldl (app2 f) (SExp $ HCon i []) $ letify "r" . preprocess <$> es | 370 | Con i es -> foldl (app2 f) (SExp $ HCon i mempty) $ letify "r" . preprocess <$> es |
393 | where | 371 | where |
394 | f [] (HCon i vs) [] (HVar_ v) = ([], HCon i $ vs ++ [v]) | 372 | f (HCon i vs) (HVar_ v) = HCon i $ vs ++ [v] |
395 | where | 373 | where |
396 | add' p (ExpC n ls ps e) = ExpC n ls (ps ++ [up' n p]) e | 374 | add' p (ExpC n ls e) = ExpC n ls $ HPiece (up' n p) e |
397 | 375 | ||
398 | app2 g e@(ExpC n ls ps f) e'@(ExpC n' ls' ps' f') = ExpC (n+n') (up n n' ls <> up 0 n ls') ps'' f'' | 376 | app2 g e@(ExpC n ls f) e'@(ExpC n' ls' f') = ExpC (n+n') (up n n' ls ++! up 0 n ls') f'' |
399 | where | 377 | where |
400 | (ps'', f'') = g (up n n' ps) (up n n' f) (up 0 n ps') (up 0 n f') | 378 | f'' = g (up n n' f) (up 0 n f') |
401 | 379 | ||
402 | letify :: Info String -> EExp -> EExp | 380 | letify :: Info String -> EExp -> EExp |
403 | letify s e@LExp{} = e | 381 | letify s e@LExp{} = e |
404 | letify s (ExpC n ls ps e) = LExp (n+1) (up n 1 $ ls <> [({-s,-} PExp ps e)]) n | 382 | letify s (ExpC n ls e) = LExp (n+1) (up n 1 $ ls <> [({-s,-} SExp e)]) n |
405 | 383 | ||
406 | ------------------------------------------------- | 384 | ------------------------------------------------- |
407 | 385 | ||
@@ -413,26 +391,29 @@ steps :: GCConfig -> EExp -> EExp | |||
413 | steps (gc1, gc2, gc3, gc4) e = runST (init e) | 391 | steps (gc1, gc2, gc3, gc4) e = runST (init e) |
414 | where | 392 | where |
415 | init :: forall s . EExp -> ST s EExp | 393 | init :: forall s . EExp -> ST s EExp |
416 | init (ExpC n ls ps e) = do | 394 | init (ExpC n ls e) = do |
417 | v1 <- new n | 395 | v1 <- new n |
418 | v2 <- new gc4 | 396 | v2 <- new gc4 |
419 | v1' <- append v1 (n, ls) | 397 | v1' <- append v1 (n, ls) |
420 | trace "-----" $ vsteps (n, 0, []) (v1', v2) [ps] e | 398 | trace "-----" $ vsteps (n, 0, []) (v1', v2) [] e |
421 | where | 399 | where |
422 | vsteps :: (Int, Int, [Int]) -> Vecs s -> [[EnvPiece EExp]] -> HNF EExp -> ST s EExp | 400 | vsteps :: (Int, Int, [Int]) -> Vecs s -> [EnvPiece] -> HNF -> ST s EExp |
401 | |||
402 | vsteps sn ls ps (HPiece p e) = vsteps sn ls (p: ps) e | ||
403 | |||
423 | vsteps sn ls@(v1@(len -> n), v2@(len -> n')) ps e@(HVar_ i) | 404 | vsteps sn ls@(v1@(len -> n), v2@(len -> n')) ps e@(HVar_ i) |
424 | | i < 0 || i >= n + n' = final sn ls ps e | 405 | | i < 0 || i >= n + n' = final sn ls ps e |
425 | | i < n = do | 406 | | i < n = do |
426 | (adjust (n + n') -> e) <- read_ v1 i | 407 | (adjust (n + n') -> e) <- read_ v1 i |
427 | if isHNF e | 408 | if isHNF e |
428 | then addLets sn ls ps e | 409 | then addLets sn ls ps e |
429 | else write v1 i ErrExp >>= \v1 -> addLets sn (v1, v2) ([Update i]: ps) e | 410 | else write v1 i ErrExp >>= \v1 -> addLets sn (v1, v2) (Update i: ps) e |
430 | | i < n + n' = do | 411 | | i < n + n' = do |
431 | (adjust (n + n') -> e) <- read_ v2 (i-n) | 412 | (adjust (n + n') -> e) <- read_ v2 (i-n) |
432 | if isHNF e | 413 | if isHNF e |
433 | then addLets sn ls ps e | 414 | then addLets sn ls ps e |
434 | else write v2 (i-n) ErrExp >>= \v2 -> addLets sn (v1, v2) ([Update i]: ps) e | 415 | else write v2 (i-n) ErrExp >>= \v2 -> addLets sn (v1, v2) (Update i: ps) e |
435 | vsteps sn@(gc1, gc2, argh) ls@(v1@(len -> n), v2@(len -> n')) (getC -> Just (p, ps)) e | 416 | vsteps sn@(gc1, gc2, argh) ls@(v1@(len -> n), v2@(len -> n')) (p: ps) e |
436 | | Update i <- p = if i < n | 417 | | Update i <- p = if i < n |
437 | then do | 418 | then do |
438 | v1' <- write v1 i $ SExp e | 419 | v1' <- write v1 i $ SExp e |
@@ -445,10 +426,10 @@ steps (gc1, gc2, gc3, gc4) e = runST (init e) | |||
445 | 426 | ||
446 | final sn v ps e = majorGC sn v ps e $ \sn' (v1@(len -> n), _) ps' e' -> do | 427 | final sn v ps e = majorGC sn v ps e $ \sn' (v1@(len -> n), _) ps' e' -> do |
447 | ls' <- vToList v1 | 428 | ls' <- vToList v1 |
448 | return $ ExpC n ls' (concat ps') e' | 429 | return $ ExpC n ls' $ foldl (flip HPiece) e' ps' |
449 | 430 | ||
450 | dx len (EApp (LExp n ls z)) (HLam i (ExpC n' ls' ps' e)) | 431 | dx len (EApp (LExp n ls z)) (HLam i (ExpC n' ls' e)) |
451 | = Just $ ExpC (n + n') (rearrange' upFun ls <> rearrange' fu ls') (rearrange' fu ps') $ rearrange' fu e | 432 | = Just $ ExpC (n + n') (rearrange' upFun ls ++! rearrange' fu ls') $ rearrange' fu e |
452 | where | 433 | where |
453 | z' = if z < 0 then z else if z < n then z + len else z - n | 434 | z' = if z < 0 then z else if z < n then z + len else z - n |
454 | fu i | i < n' = i + n + len | 435 | fu i | i < n' = i + n + len |
@@ -458,36 +439,37 @@ steps (gc1, gc2, gc3, gc4) e = runST (init e) | |||
458 | upFun i = if i < n then i + len else i - n | 439 | upFun i = if i < n then i + len else i - n |
459 | 440 | ||
460 | dx len (ECase _ cs) (HCon (_, i) vs@(length -> n)) | 441 | dx len (ECase _ cs) (HCon (_, i) vs@(length -> n)) |
461 | | n' == 0 && n == 0 = Just e | 442 | | nn == 0 = Just e |
462 | | otherwise = Just $ adjust' (\i -> if i < n' then i + len else if i - n' < n then vs !! (n - (i - n') - 1) else i - n - n') e | 443 | | otherwise = Just $ adjust' (\i -> if i < n' then i + len else if i < nn then vs !! (nn - 1 - i) else i - nn) e |
463 | where | 444 | where |
464 | e@(ExpC n' _ _ _) = cs !! i | 445 | !nn = n + n' |
446 | !e@(ExpC n' _ _) = cs !! i | ||
465 | dx len (EDelta SeqOp [] [f]) x | 447 | dx len (EDelta SeqOp [] [f]) x |
466 | | isHNF' x = Just $ adjust len f | 448 | | isHNF' x = Just $ adjust len f |
467 | | otherwise = Nothing | 449 | | otherwise = Nothing |
468 | dx len (EDelta o lits (ExpC n ls ps f: fs)) (HLit l) | 450 | dx len (EDelta o lits (ExpC n ls f: fs)) (HLit l) |
469 | = Just $ adjust len $ ExpC n ls (ps ++ [EDelta o (l: lits) fs]) f | 451 | = Just $ adjust len $ ExpC n ls $ HPiece (EDelta o (l: lits) fs) f |
470 | dx len (EDelta o lits []) (HLit l) | 452 | dx len (EDelta o lits []) (HLit l) |
471 | = Just $ SExp $ delta o $ l: lits | 453 | = Just $ SExp $ delta o $ l: lits |
472 | dx _ _ _ = Nothing | 454 | dx _ _ _ = Nothing |
473 | 455 | ||
474 | addLets sn ls ps (PExp ps' e) = vsteps sn ls (ps': ps) e | 456 | addLets sn ls ps (SExp e) = vsteps sn ls ps e |
475 | addLets sn ls@(v1, v2) ps (ExpC n' xs ps' e) = do | 457 | addLets sn ls@(v1, v2) ps (ExpC n' xs e) = do |
476 | v2' <- append v2 (n', xs) | 458 | v2' <- append v2 (n', xs) |
477 | mkGC sn (v1, v2') (ps': ps) e | 459 | mkGC sn (v1, v2') ps e |
478 | 460 | ||
479 | mkGC sn@(mg, sn_, xx) v@(len -> n, len -> n') ps e | 461 | mkGC sn@(mg, sn_, xx) v@(len -> n, len -> n') ps e |
480 | | n' < gc2 = vsteps (mg, sn_ + 1, xx) v ps e | 462 | | n' < gc2 = vsteps (mg, sn_ + 1, xx) v ps e |
481 | | n + n' - mg < gc1 = minorGC sn v ps e | 463 | | n + n' - mg < gc1 = minorGC sn v ps e |
482 | | otherwise = majorGC sn v ps e vsteps | 464 | | otherwise = majorGC sn v ps e vsteps |
483 | 465 | ||
484 | adjust _ e@PExp{} = e | 466 | adjust _ e@SExp{} = e |
485 | adjust n e@(ExpC n' _ _ _) = adjust' (\i -> if i < n' then i + n else i - n') e | 467 | adjust n e@(ExpC n' _ _) = adjust' (\i -> if i < n' then i + n else i - n') e |
486 | 468 | ||
487 | adjust' fu (ExpC n' xs ps' e) = ExpC n' (rearrange' fu xs) (rearrange' fu ps') (rearrange' fu e) | 469 | adjust' fu (ExpC n' xs e) = ExpC n' (rearrange' fu xs) (rearrange' fu e) |
488 | 470 | ||
489 | minorGC :: (Int, Int, [Int]) -> Vecs s -> [[EnvPiece EExp]] -> HNF EExp -> ST s EExp | 471 | minorGC :: (Int, Int, [Int]) -> Vecs s -> [EnvPiece] -> HNF -> ST s EExp |
490 | minorGC (mg, sn, argh) (v1@(len -> n), v2@(len -> n')) (concat -> ps) e = do | 472 | minorGC (mg, sn, argh) (v1@(len -> n), v2@(len -> n')) ps e = do |
491 | fv2 <- freezedRead v2 | 473 | fv2 <- freezedRead v2 |
492 | genericGC_ fv2 n n' $ \mark co -> do | 474 | genericGC_ fv2 n n' $ \mark co -> do |
493 | let cc (xx, acc) i = do | 475 | let cc (xx, acc) i = do |
@@ -503,12 +485,12 @@ steps (gc1, gc2, gc3, gc4) e = runST (init e) | |||
503 | trace ("minor gc: " ++ show (n - la) ++ " + " ++ show (la - la') ++ " + " ++ show la' ++ " + " ++ show xx' ++ " + " ++ show (n' - xx') ++ " - " ++ show (n + n' - n'')) $ do | 485 | trace ("minor gc: " ++ show (n - la) ++ " + " ++ show (la - la') ++ " + " ++ show la' ++ " + " ++ show xx' ++ " + " ++ show (n' - xx') ++ " - " ++ show (n + n' - n'')) $ do |
504 | v1'' <- foldM (\v i -> modify v i $ sfv fvi n) v1' argh' | 486 | v1'' <- foldM (\v i -> modify v i $ sfv fvi n) v1' argh' |
505 | v2' <- new gc3 | 487 | v2' <- new gc3 |
506 | vsteps (mg, sn + 1, []) (v1'', v2') [sfv fvi n ps] (sfv fvi n e) | 488 | vsteps (mg, sn + 1, []) (v1'', v2') (sfv fvi n ps) (sfv fvi n e) |
507 | 489 | ||
508 | majorGC :: (Int, Int, [Int]) -> Vecs s -> [[EnvPiece EExp]] -> HNF EExp | 490 | majorGC :: (Int, Int, [Int]) -> Vecs s -> [EnvPiece] -> HNF |
509 | -> ((Int, Int, [Int]) -> Vecs s -> [[EnvPiece EExp]] -> HNF EExp -> ST s e) | 491 | -> ((Int, Int, [Int]) -> Vecs s -> [EnvPiece] -> HNF -> ST s e) |
510 | -> ST s e | 492 | -> ST s e |
511 | majorGC (_, sn, argh) v@(v1@(len -> n), v2@(len -> n')) (concat -> ps) e cont = do | 493 | majorGC (_, sn, argh) v@(v1@(len -> n), v2@(len -> n')) ps e cont = do |
512 | fv1 <- freezedRead v1 | 494 | fv1 <- freezedRead v1 |
513 | fv2 <- freezedRead v2 | 495 | fv2 <- freezedRead v2 |
514 | let read2 i = if i < n then fv1 i else fv2 (i - n) | 496 | let read2 i = if i < n then fv1 i else fv2 (i - n) |
@@ -518,7 +500,7 @@ steps (gc1, gc2, gc3, gc4) e = runST (init e) | |||
518 | \fvi v1'@(len -> n'') -> | 500 | \fvi v1'@(len -> n'') -> |
519 | trace ("major gc: " ++ show n ++ " + " ++ show n' ++ " - " ++ show (n + n' - n'')) $ do | 501 | trace ("major gc: " ++ show n ++ " + " ++ show n' ++ " - " ++ show (n + n' - n'')) $ do |
520 | v2' <- new gc3 | 502 | v2' <- new gc3 |
521 | cont (n'', sn + 1, []) (v1', v2') [sfv fvi 0 ps] (sfv fvi 0 e) | 503 | cont (n'', sn + 1, []) (v1', v2') (sfv fvi 0 ps) (sfv fvi 0 e) |
522 | 504 | ||
523 | genericGC_ read_ n len cont = do | 505 | genericGC_ read_ n len cont = do |
524 | vi <- UV.replicate len nogc_mark | 506 | vi <- UV.replicate len nogc_mark |
@@ -534,16 +516,16 @@ steps (gc1, gc2, gc3, gc4) e = runST (init e) | |||
534 | cont fvi =<< sweep 0 vv | 516 | cont fvi =<< sweep 0 vv |
535 | where | 517 | where |
536 | mark vi read_ n acc i t = do | 518 | mark vi read_ n acc i t = do |
537 | ma <- UV.read vi i | 519 | ma <- UV.unsafeRead vi i |
538 | if ma /= nogc_mark then writes ma >> return t else | 520 | if ma /= nogc_mark then writes ma >> return t else |
539 | case read_ i of | 521 | case read_ i of |
540 | ERef r | r >= n -> mark vi read_ n (i: acc) (r - n) t | 522 | ERef r | r >= n -> mark vi read_ n (i: acc) (r - n) t |
541 | e -> do | 523 | e -> do |
542 | writes t | 524 | writes t |
543 | UV.write vi i t | 525 | UV.unsafeWrite vi i t |
544 | fv (mark vi read_ n []) n e $ t+1 | 526 | fv (mark vi read_ n []) n e $ t+1 |
545 | where | 527 | where |
546 | writes t = forM_ acc $ \i -> UV.write vi i t | 528 | writes t = forM_ acc $ \i -> UV.unsafeWrite vi i t |
547 | 529 | ||
548 | delta ISqrt [LInt i] = HLit $ LInt $ round $ sqrt $ fromIntegral i | 530 | delta ISqrt [LInt i] = HLit $ LInt $ round $ sqrt $ fromIntegral i |
549 | delta LessEq [LInt j, LInt i] = mkBool $ i <= j | 531 | delta LessEq [LInt j, LInt i] = mkBool $ i <= j |
@@ -553,19 +535,15 @@ delta Sub [LInt j, LInt i] = HLit $ LInt $ i - j | |||
553 | delta Mod [LInt j, LInt i] = HLit $ LInt $ i `mod` j | 535 | delta Mod [LInt j, LInt i] = HLit $ LInt $ i `mod` j |
554 | delta o ls = error $ "delta: " ++ show o ++ "\n" ++ show ls | 536 | delta o ls = error $ "delta: " ++ show o ++ "\n" ++ show ls |
555 | 537 | ||
556 | mkBool b = HCon (if b then ("True", 1) else ("False", 0)) [] | 538 | mkBool b = HCon (if b then ("True", 1) else ("False", 0)) mempty |
557 | 539 | ||
558 | isHNF ERef{} = False | 540 | isHNF (SExp x) = isHNF' x |
559 | isHNF SExp{} = True | ||
560 | isHNF _ = False | 541 | isHNF _ = False |
561 | 542 | ||
562 | isHNF' HVar_{} = False | 543 | isHNF' HVar_{} = False |
544 | isHNF' HPiece{} = False | ||
563 | isHNF' _ = True | 545 | isHNF' _ = True |
564 | 546 | ||
565 | getC ((x: xs): xss) = Just (x, xs: xss) | ||
566 | getC ([]: xss) = getC xss | ||
567 | getC _ = Nothing | ||
568 | |||
569 | --------------------------------------------------------------- pretty print | 547 | --------------------------------------------------------------- pretty print |
570 | 548 | ||
571 | newtype Info a = Info {getInfo :: a} | 549 | newtype Info a = Info {getInfo :: a} |
@@ -603,25 +581,26 @@ showLam x (DFreshName u d) = DFreshName u $ showLam (DUp 0 x) d | |||
603 | showLam x (DLam xs y) = DLam (DSep (InfixR 11) x xs) y | 581 | showLam x (DLam xs y) = DLam (DSep (InfixR 11) x xs) y |
604 | showLam x y = DLam x y | 582 | showLam x y = DLam x y |
605 | 583 | ||
606 | instance PShow e => PShow (HNF e) where | 584 | instance PShow HNF where |
607 | pShow = \case | 585 | pShow = \case |
608 | HLam n e -> shLam (getInfo n) $ pShow e | 586 | HLam n e -> shLam (getInfo n) $ pShow e |
609 | HCon (s, _) is -> foldl DApp (text s) $ dVar <$> is | 587 | HCon (s, _) is -> foldl DApp (text s) $ dVar <$> is |
610 | HLit l -> pShow l | 588 | HLit l -> pShow l |
611 | HVar_ i -> dVar i | 589 | HVar_ i -> dVar i |
590 | HPiece p e -> showPiece (pShow e) p | ||
612 | 591 | ||
613 | dVar (Pos i) = DVar i | 592 | dVar (Pos i) = DVar i |
614 | dVar (Neg i) = text $ "v" ++ show i | 593 | dVar (Neg i) = text $ "v" ++ show i |
615 | 594 | ||
616 | instance PShow EExp where | 595 | instance PShow EExp where |
617 | pShow ErrExp = text "_|_" | 596 | pShow ErrExp = text "_|_" |
618 | pShow (ExpC n ls ps e) = shLet ((,) "x" . pShow <$> ls) $ foldl h (pShow e) ps | 597 | pShow (ExpC _ ls e) = shLet ((,) "x" . pShow <$> ls) $ pShow e |
619 | where | 598 | |
620 | h e = \case | 599 | showPiece e = \case |
621 | EApp x -> e `DApp` pShow x | 600 | EApp x -> e `DApp` pShow x |
622 | ECase (cns, _) xs -> shCase cns e $ pShow <$> xs | 601 | ECase (cns, _) xs -> shCase cns e $ pShow <$> xs |
623 | Update_ i -> DOp "@" (InfixR 14) (dVar i) e | 602 | Update_ i -> DOp "@" (InfixR 14) (dVar i) e |
624 | EDelta o ls es -> shDelta o $ (pShow <$> ls) ++ e: (pShow <$> es) | 603 | EDelta o ls es -> shDelta o $ (pShow <$> ls) ++ e: (pShow <$> es) |
625 | {- | 604 | {- |
626 | instance PShow Exp where | 605 | instance PShow Exp where |
627 | pShow = \case | 606 | pShow = \case |