Skip to content

Commit f64d6b0

Browse files
phantamanta44phantamanta44
committed
Revert bubble re-implementation
1 parent 9c422c8 commit f64d6b0

File tree

1 file changed

+130
-73
lines changed

1 file changed

+130
-73
lines changed

‎src/compiler/api/GF/Compile/Compute/Concrete2.hs‎

Lines changed: 130 additions & 73 deletions
Original file line numberDiff line numberDiff line change
@@ -394,81 +394,138 @@ apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs)
394394
apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs
395395
apply g v [] = v
396396

397-
data Bubbled a
398-
= BLeaf a
399-
| BFree Choice [Bubbled a]
400-
| BOpts Choice Value Value [(Value, Value, Bubbled a)]
397+
data BubbleVariants
398+
= BubbleFree Int
399+
| BubbleOpts Value Value [(Value, Value)]
401400

402-
instance Functor Bubbled where
403-
fmap = liftM
404-
405-
instance Applicative Bubbled where
406-
pure = BLeaf
407-
(<*>) = ap
408-
409-
instance Monad Bubbled where
410-
BLeaf a >>= k = k a
411-
BFree c as >>= k = BFree c ((>>= k) <$> as)
412-
BOpts c nty n as >>= k = BOpts c nty n (third (>>= k) <$> as)
413-
414-
unbubble :: Bubbled Value -> Value
415-
unbubble (BLeaf v) = v
416-
unbubble (BFree c vs) = VFV c (VarFree (unbubble <$> vs))
417-
unbubble (BOpts c nty n cs) = VFV c (VarOpts nty n (third unbubble <$> cs))
418-
419-
bubble v = unbubble (bubble' v)
401+
bubble v = snd (bubble v)
420402
where
421-
bubble' :: Value -> Bubbled Value
422-
bubble' (VApp c f vs) = liftL (VApp c f) vs
423-
bubble' (VMeta metaid vs) = liftL (VMeta metaid) vs
424-
bubble' (VSusp metaid k vs) = liftL (VSusp metaid k) vs
425-
bubble' (VGen i vs) = liftL (VGen i) vs
426-
bubble' (VClosure env c t) = liftL' (\env -> VClosure env c t) env
427-
bubble' (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
428-
bubble' (VRecType as) = liftL' VRecType as
429-
bubble' (VR as) = liftL' VR as
430-
bubble' (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
431-
bubble' (VExtR v1 v2) = lift2 VExtR v1 v2
432-
bubble' (VTable v1 v2) = lift2 VTable v1 v2
433-
bubble' (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
434-
bubble' (VV v vs) = lift1L VV v vs
435-
bubble' (VS v1 v2 vs) = lift2L VS v1 v2 vs
436-
bubble' v@(VSort _) = lift0 v
437-
bubble' v@(VInt _) = lift0 v
438-
bubble' v@(VFlt _) = lift0 v
439-
bubble' v@(VStr _) = lift0 v
440-
bubble' v@VEmpty = lift0 v
441-
bubble' (VC v1 v2) = lift2 VC v1 v2
442-
bubble' (VGlue v1 v2) = lift2 VGlue v1 v2
443-
bubble' v@(VPatt _ _ _) = lift0 v
444-
bubble' (VPattType v) = lift1 VPattType v
445-
bubble' (VFV c (VarFree vs)) = BFree c (bubble' <$> vs)
446-
bubble' (VFV c (VarOpts nty n os)) = BOpts c nty n (third bubble' <$> os)
447-
bubble' (VAlts v vs) = lift1L2 VAlts v vs
448-
bubble' (VStrs vs) = liftL VStrs vs
449-
bubble' (VMarkup tag attrs vs) = do
450-
attrs' <- mapM (secondM bubble') attrs
451-
vs' <- mapM bubble' vs
452-
return $ VMarkup tag attrs' vs'
453-
bubble' (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
454-
bubble' (VSymCat d i0 vs) = do
455-
vs' <- forM vs $ \(i,(v,ty)) -> (i,) . (,ty) <$> bubble' v
456-
return $ VSymCat d i0 vs'
457-
bubble' v@(VError _) = lift0 v
458-
bubble' v@(VCRecType lbls) = do
459-
lbls' <- forM lbls $ \(l,b,v) -> (l,b,) <$> bubble' v
460-
return $ VCRecType lbls'
461-
bubble' v@(VCInts _ _) = lift0 v
462-
463-
lift0 = BLeaf
464-
lift1 f v = f <$> bubble' v
465-
liftL f vs = f <$> mapM bubble' vs
466-
liftL' f xvs = f <$> mapM (secondM bubble') xvs
467-
lift1L f v vs = liftM2 f (bubble' v) (mapM bubble' vs)
468-
lift1L' f v xvs = liftM2 f (bubble' v) (mapM (secondM bubble') xvs)
469-
lift1L2 f v uvs = liftM2 f (bubble' v) (mapM (bimapM bubble' bubble') uvs)
470-
lift2L f v1 v2 vs = liftM3 f (bubble' v1) (bubble' v2) (mapM bubble' vs)
471-
lift2 f v1 v2 = liftM2 f (bubble' v1) (bubble' v2)
403+
bubble (VApp c f vs) = liftL (VApp c f) vs
404+
bubble (VMeta metaid vs) = liftL (VMeta metaid) vs
405+
bubble (VSusp metaid k vs) = liftL (VSusp metaid k) vs
406+
bubble (VGen i vs) = liftL (VGen i) vs
407+
bubble (VClosure env c t) = liftL' (\env -> VClosure env c t) env
408+
bubble (VProd bt x v1 v2) = lift2 (VProd bt x) v1 v2
409+
bubble (VRecType as) = liftL' VRecType as
410+
bubble (VR as) = liftL' VR as
411+
bubble (VP v l vs) = lift1L (\v vs -> VP v l vs) v vs
412+
bubble (VExtR v1 v2) = lift2 VExtR v1 v2
413+
bubble (VTable v1 v2) = lift2 VTable v1 v2
414+
bubble (VT v env c cs) = lift1L' (\v env -> VT v env c cs) v env
415+
bubble (VV v vs) = lift1L VV v vs
416+
bubble (VS v1 v2 vs) = lift2L VS v1 v2 vs
417+
bubble v@(VSort _) = lift0 v
418+
bubble v@(VInt _) = lift0 v
419+
bubble v@(VFlt _) = lift0 v
420+
bubble v@(VStr _) = lift0 v
421+
bubble v@VEmpty = lift0 v
422+
bubble (VC v1 v2) = lift2 VC v1 v2
423+
bubble (VGlue v1 v2) = lift2 VGlue v1 v2
424+
bubble v@(VPatt _ _ _) = lift0 v
425+
bubble (VPattType v) = lift1 VPattType v
426+
bubble v@(VFV c (VarFree vs))
427+
| null vs = (Map.empty, v)
428+
| otherwise = let (union,vs') = mapAccumL descend Map.empty vs
429+
b = BubbleFree (length vs)
430+
v' = addVariants (VFV c (VarFree vs')) union
431+
in (Map.insert c (b,1) union, v')
432+
bubble v@(VFV c (VarOpts nty n os))
433+
| null os = (Map.empty, v)
434+
| otherwise = let (union,os') = mapAccumL (\acc (lty,l,v) -> second (lty,l,) $ descend acc v) Map.empty os
435+
b = BubbleOpts nty n (os <&> \(lty,l,_) -> (lty,l))
436+
v' = addVariants (VFV c (VarOpts nty n os')) union
437+
in (Map.insert c (b,1) union, v')
438+
bubble (VAlts v vs) = lift1L2 VAlts v vs
439+
bubble (VStrs vs) = liftL VStrs vs
440+
bubble (VMarkup tag attrs vs) =
441+
let (union1,attrs') = mapAccumL descend' Map.empty attrs
442+
(union2,vs') = mapAccumL descend union1 vs
443+
in (union2, VMarkup tag attrs' vs')
444+
bubble (VReset ctl mb_cv v id) = lift1 (\v -> VReset ctl mb_cv v id) v
445+
bubble (VSymCat d i0 vs) =
446+
let (union,vs') = mapAccumL descendC Map.empty vs
447+
in (union, addVariants (VSymCat d i0 vs') union)
448+
bubble v@(VError _) = lift0 v
449+
bubble v@(VCRecType lbls) =
450+
let (union,lbls') = mapAccumL descendR Map.empty lbls
451+
in (union, addVariants (VCRecType lbls') union)
452+
bubble v@(VCInts _ _) = lift0 v
453+
454+
lift0 v = (Map.empty, v)
455+
456+
lift1 f v =
457+
let (union,v') = bubble v
458+
in (union,f v')
459+
460+
liftL f vs =
461+
let (union,vs') = mapAccumL descend Map.empty vs
462+
in (union, addVariants (f vs') union)
463+
464+
liftL' f vs =
465+
let (union,vs') = mapAccumL descend' Map.empty vs
466+
in (union, addVariants (f vs') union)
467+
468+
lift1L f v vs =
469+
let (choices,v') = bubble v
470+
(union, vs') = mapAccumL descend (unitfy choices) vs
471+
in (union, addVariants (f v' vs') union)
472+
473+
lift1L' f v vs =
474+
let (choices,v') = bubble v
475+
(union, vs') = mapAccumL descend' (unitfy choices) vs
476+
in (union, addVariants (f v' vs') union)
477+
478+
lift1L2 f v vs =
479+
let (choices,v') = bubble v
480+
(union, vs') = mapAccumL descend2 (unitfy choices) vs
481+
in (union, addVariants (f v' vs') union)
482+
483+
lift2L f v1 v2 vs =
484+
let (choices1,v1') = bubble v1
485+
(choices2,v2') = bubble v2
486+
union = mergeChoices2 choices1 choices2
487+
(union', vs') = mapAccumL descend union vs
488+
in (union', addVariants (f v1' v2' vs') union')
489+
490+
lift2 f v1 v2 =
491+
let (choices1,v1') = bubble v1
492+
(choices2,v2') = bubble v2
493+
union = mergeChoices2 choices1 choices2
494+
in (union, addVariants (f v1' v2') union)
495+
496+
descend union v =
497+
let (choices,v') = bubble v
498+
in (mergeChoices1 union choices,v')
499+
500+
descend' :: Map.Map Choice (BubbleVariants,Int) -> (a,Value) -> (Map.Map Choice (BubbleVariants,Int),(a,Value))
501+
descend' union (x,v) =
502+
let (choices,v') = bubble v
503+
in (mergeChoices1 union choices,(x,v'))
504+
505+
descend2 union (v1,v2) =
506+
let (choices1,v1') = bubble v1
507+
(choices2,v2') = bubble v2
508+
in (mergeChoices1 (mergeChoices1 union choices1) choices2,(v1',v2'))
509+
510+
descendC union (i,(v,ty)) =
511+
let (choices,v') = bubble v
512+
in (mergeChoices1 union choices,(i,(v',ty)))
513+
514+
descendR union (l,b,v) =
515+
let (choices,v') = bubble v
516+
in (mergeChoices1 union choices,(l,b,v'))
517+
518+
addVariants v = Map.foldrWithKey addVariant v
519+
where
520+
addVariant c (bvs,cnt) v
521+
| cnt > 1 = VFV c $ case bvs of
522+
BubbleFree k -> VarFree (replicate k v)
523+
BubbleOpts nty n os -> VarOpts nty n (os <&> \(lty,l) -> (lty,l,v))
524+
| otherwise = v
525+
526+
unitfy = fmap (\(n,_) -> (n,1))
527+
mergeChoices1 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,cnt+1)) id unitfy
528+
mergeChoices2 = Map.mergeWithKey (\c (n,cnt) _ -> Just (n,2)) unitfy unitfy
472529

473530
toPBool True = VApp poison (cPredef,cPTrue) []
474531
toPBool False = VApp poison (cPredef,cPFalse) []

0 commit comments

Comments
 (0)