<commit_before>{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Language.Malgo.Core.LambdaLift
  ( LambdaLift,
  )
where

import qualified Data.Map as Map
import Language.Malgo.IR.Core
import Language.Malgo.Id
import Language.Malgo.Monad
import Language.Malgo.Pass
import Language.Malgo.Prelude
import Language.Malgo.TypeRep.CType

data LambdaLift

instance Pass LambdaLift (Exp (Id CType)) (Program (Id CType)) where
  passName = "lambda lift"
  isDump = dumpLambdaLift
  trans e = do
    (mainExpr, ds) <- runStateT (llift e) mempty
    mainId <- newId (PackT [Con "Tuple0" []] :-> cTypeOf mainExpr) "$main"
    hole <- newId (PackT [Con "Tuple0" []]) "$hole"
    pure $ Program mainId ((mainId, Fun [hole] mainExpr) : Map.assocs ds)

llift ::
  ( MonadUniq f,
    MonadState (Map (Id CType) (Obj (Id CType))) f
  ) =>
  Exp (Id CType) ->
  f (Exp (Id CType))
llift (Let ds e) =
  Let <$> traverse aux ds <*> llift e
  where
    aux (n, v) = case v of
      o@(Fun as body) -> do
        let fvs = toList $ freevars o
        if null fvs
          then (n,) <$> (Fun as <$> llift body)
          else do
            newFun <- def (n ^. idName) (fvs <> as) =<< llift body
            pure (n, Fun as (Call newFun $ map Var fvs))
      o -> pure (n, o)
llift (Match e cs) =
  Match <$> llift e <*> traverse aux cs
  where
    aux (Unpack con ps body) = Unpack con ps <$> llift body
    aux (Bind x body) = Bind x <$> llift body
llift e = pure e

def ::
  ( MonadUniq m,
    MonadState (Map (Id CType) (Obj (Id CType))) m
  ) =>
  String ->
  [Id CType] ->
  Exp (Id CType) ->
  m (Id CType)
def name xs e = do
  f <- newId (foldr ((:->) . cTypeOf) (cTypeOf e) xs) ("$" <> name)
  modify $ Map.insert f (Fun xs e)
  pure f<commit_msg>持ち上げない関数の判定を改良<commit_after>{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Language.Malgo.Core.LambdaLift
  ( LambdaLift,
  )
where

import qualified Data.Map as Map
import Language.Malgo.IR.Core
import Language.Malgo.Id
import Language.Malgo.Monad
import Language.Malgo.Pass
import Language.Malgo.Prelude
import Language.Malgo.TypeRep.CType

data LambdaLift

instance Pass LambdaLift (Exp (Id CType)) (Program (Id CType)) where
  passName = "lambda lift"
  isDump = dumpLambdaLift
  trans e = do
    (mainExpr, ds) <- runStateT (llift e) mempty
    mainId <- newId (PackT [Con "Tuple0" []] :-> cTypeOf mainExpr) "$main"
    hole <- newId (PackT [Con "Tuple0" []]) "$hole"
    pure $ Program mainId ((mainId, Fun [hole] mainExpr) : Map.assocs ds)

llift ::
  ( MonadUniq f,
    MonadState (Map (Id CType) (Obj (Id CType))) f
  ) =>
  Exp (Id CType) ->
  f (Exp (Id CType))
llift (Let ds e) =
  Let <$> traverse aux ds <*> llift e
  where
    aux (n, v) = case v of
      o@(Fun _ Call {}) -> pure (n, o)
      o@(Fun _ PrimCall {}) -> pure (n, o)
      o@(Fun as body) -> do
        let fvs = toList $ freevars o
        newFun <- def (n ^. idName) (fvs <> as) =<< llift body
        pure (n, Fun as (Call newFun $ map Var $ fvs <> as))
      o -> pure (n, o)
llift (Match e cs) =
  Match <$> llift e <*> traverse aux cs
  where
    aux (Unpack con ps body) = Unpack con ps <$> llift body
    aux (Bind x body) = Bind x <$> llift body
llift e = pure e

def ::
  ( MonadUniq m,
    MonadState (Map (Id CType) (Obj (Id CType))) m
  ) =>
  String ->
  [Id CType] ->
  Exp (Id CType) ->
  m (Id CType)
def name xs e = do
  f <- newId (foldr ((:->) . cTypeOf) (cTypeOf e) xs) ("$" <> name)
  modify $ Map.insert f (Fun xs e)
  pure f
{'fraction_non_alphanumeric': 0.14635430376414846, 'fraction_numerical': 0.0010529086601737299, 'mean_word_length': 2.834510595358224, 'pattern_counts': {'":': 0, '<': 36, '<?xml version=': 0, '>': 44, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2961975', 'n_tokens_mistral': 1503, 'n_tokens_neox': 1477, 'n_words': 465}