Có thể làm cho GHC tối ưu hóa (deforest) các chức năng chung như catamorphisms?

Question

Tôi thực sự thích ý tưởng về làm việc với catamorphisms/anamorphisms một cách chung chung, nhưng có vẻ như với tôi nó có một hiệu suất nhược điểm đáng kể:

Giả sử chúng ta muốn làm việc với một cấu trúc cây trong cách phân loại - để mô tả gấp khác nhau bằng cách sử dụng chung catamorphism function:

newtype Fix f = Fix { unfix :: f (Fix f) } 

data TreeT r = Leaf | Tree r r 
instance Functor TreeT where 
    fmap f Leaf   = Leaf 
    fmap f (Tree l r) = Tree (f l) (f r) 

type Tree = Fix TreeT 

catam :: (Functor f) => (f a -> a) -> (Fix f -> a) 
catam f = f . fmap (catam f) . unfix 

Bây giờ chúng ta có thể viết các chức năng như:

depth1 :: Tree -> Int 
depth1 = catam g 
    where 
    g Leaf  = 0 
    g (Tree l r) = max l r 

Thật không may, phương pháp này có một nhược điểm đáng kể: Dur tính toán, các phiên bản mới của TreeT Int được tạo ở mọi cấp độ trong fmap chỉ để được tiêu thụ ngay lập tức bởi g. So với định nghĩa cổ điển

depth2 :: Tree -> Int 
depth2 (Fix Leaf) = 0 
depth2 (Fix (Tree l r)) = max (depth1 l) (depth1 r) 

depth1 của chúng tôi sẽ luôn làm chậm sự căng thẳng không cần thiết trên GC. Một giải pháp là sử dụng hylomorphisms và kết hợp các cây tạo và gấp lại với nhau. Nhưng thường chúng ta không muốn làm điều đó, chúng ta có thể muốn một cây được tạo ra ở một nơi và sau đó đi qua một nơi khác để được xếp lại sau. Hoặc, để được thư mục nhiều lần với catamorphisms khác nhau.

Có cách nào giúp GHC tối ưu hóa depth1 không? Nội dung nào đó như inlining catam g và sau đó fusing/deforestingg . fmap ... bên trong?

Answer 1

Tôi tin rằng tôi đã tìm thấy câu trả lời. Tôi nhớ đọc Why does GHC make fix so confounding? và đề xuất cho tôi một giải pháp.

Sự cố với định nghĩa trước đây là catam là nó đệ quy và vì vậy mọi nỗ lực INLINE đều bị bỏ qua. Biên soạn phiên bản gốc với -ddump-simpl -ddump-to-file và đọc core:

Main.depth1 = Main.catam_$scatam @ GHC.Types.Int Main.depth3 

Main.depth3 = 
    \ (ds_dyI :: Main.TreeT GHC.Types.Int) -> 
    case ds_dyI of _ { 
     Main.Leaf -> Main.depth4; 
     Main.Tree l_aah r_aai -> GHC.Classes.$fOrdInt_$cmax l_aah r_aai 
    } 

Main.depth4 = GHC.Types.I# 0 

Rec { 
Main.catam_$scatam = 
    \ (@ a_ajB) 
    (eta_B1 :: Main.TreeT a_ajB -> a_ajB) 
    (eta1_X2 :: Main.Fix Main.TreeT) -> 
    eta_B1 
     (case eta1_X2 
      `cast` (Main.NTCo:Fix <Main.TreeT> 
        :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT)) 
     of _ { 
     Main.Leaf -> Main.Leaf @ a_ajB; 
     Main.Tree l_aan r_aao -> 
      Main.Tree 
      @ a_ajB 
      (Main.catam_$scatam @ a_ajB eta_B1 l_aan) 
      (Main.catam_$scatam @ a_ajB eta_B1 r_aao) 
     }) 
end Rec } 

rõ ràng là tồi tệ hơn (tạo constructor/loại bỏ trong catam_$scatam, nhiều cuộc gọi chức năng) so với

Main.depth2 = 
    \ (w_s1Rz :: Main.Tree) -> 
    case Main.$wdepth2 w_s1Rz of ww_s1RC { __DEFAULT -> 
    GHC.Types.I# ww_s1RC 
    } 

Rec { 
Main.$wdepth2 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int# 
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S] 
Main.$wdepth2 = 
    \ (w_s1Rz :: Main.Tree) -> 
    case w_s1Rz 
     `cast` (Main.NTCo:Fix <Main.TreeT> 
       :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT)) 
    of _ { 
     Main.Leaf -> 0; 
     Main.Tree l_aaj r_aak -> 
     case Main.$wdepth2 l_aaj of ww_s1RC { __DEFAULT -> 
     case Main.$wdepth2 r_aak of ww1_X1Sh { __DEFAULT -> 
     case GHC.Prim.<=# ww_s1RC ww1_X1Sh of _ { 
      GHC.Types.False -> ww_s1RC; 
      GHC.Types.True -> ww1_X1Sh 
     } 
     } 
     } 
    } 
end Rec } 

Nhưng nếu chúng ta định nghĩa catam như

{-# INLINE catam #-} 
catam :: (Functor f) => (f a -> a) -> (Fix f -> a) 
catam f = let u = f . fmap u . unfix 
      in u 

thì không còn đệ quy nữa, chỉ bên trong là u. Bằng cách này GHC inlines catam trong định nghĩa của depth1 và cầu chì fmap với depth1 's g - chỉ là những gì chúng ta muốn:

Main.depth1 = 
    \ (w_s1RJ :: Main.Tree) -> 
    case Main.$wdepth1 w_s1RJ of ww_s1RM { __DEFAULT -> 
    GHC.Types.I# ww_s1RM 
    } 

Rec { 
Main.$wdepth1 [Occ=LoopBreaker] :: Main.Tree -> GHC.Prim.Int# 
[GblId, Arity=1, Caf=NoCafRefs, Str=DmdType S] 
Main.$wdepth1 = 
    \ (w_s1RJ :: Main.Tree) -> 
    case w_s1RJ 
     `cast` (Main.NTCo:Fix <Main.TreeT> 
       :: Main.Fix Main.TreeT ~# Main.TreeT (Main.Fix Main.TreeT)) 
    of _ { 
     Main.Leaf -> 0; 
     Main.Tree l_aar r_aas -> 
     case Main.$wdepth1 l_aar of ww_s1RM { __DEFAULT -> 
     case Main.$wdepth1 r_aas of ww1_X1So { __DEFAULT -> 
     case GHC.Prim.<=# ww_s1RM ww1_X1So of _ { 
      GHC.Types.False -> ww_s1RM; 
      GHC.Types.True -> ww1_X1So 
     } 
     } 
     } 
    } 
end Rec } 

mà bây giờ chỉ giống như các bãi chứa của depth2.