<commit_before>-------------------------------------------------------------------------------
-- |
-- Module      :  System.Hardware.Haskino.ShallowDeepPlugin.RecurPass
-- Copyright   :  (c) University of Kansas
-- License     :  BSD3
-- Stability   :  experimental
--
-- Recursion Transformation Pass
-------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Hardware.Haskino.ShallowDeepPlugin.RecurPass (recurPass) where

import Control.Monad.State
import CoreMonad
import GhcPlugins

import System.Hardware.Haskino.ShallowDeepPlugin.Utils

data BindEnv
    = BindEnv
      { pluginModGuts :: ModGuts,
        funcId        :: [Id]
      }

newtype BindM a = BindM { runBindM :: StateT BindEnv CoreM a }
    deriving (Functor, Applicative, Monad
             ,MonadIO, MonadState BindEnv)

instance PassCoreM BindM where
    liftCoreM m = BindM $ lift m
    getModGuts = gets pluginModGuts


recurPass :: ModGuts -> CoreM ModGuts
recurPass guts = do
    bindsL' <- (\x -> fst <$> (runStateT (runBindM $ (mapM recurBind) x) (BindEnv guts []))) (mg_binds guts)
    return (guts { mg_binds = concat bindsL' })

recurBind :: CoreBind -> BindM [CoreBind]
recurBind (NonRec b e) = do
    e' <- recurSubExpr e
    return [NonRec b e']
recurBind (Rec bs) = do
    (nonRec, bs') <- recurBind' bs
    return $ nonRec ++ [Rec bs']

recurBind' :: [(Id, CoreExpr)] -> BindM ([CoreBind],[(Id, CoreExpr)])
recurBind' [] = return ([],[])
recurBind' ((b, e) : bs) = do
    let defaultRet = do
          (nonrec, bs') <- recurBind' bs
          return $ (nonrec, (b, e) : bs')
    s <- get
    put s {funcId = [b]}
    let (argTys, retTy) = splitFunTys $ exprType e
    let retTyCon_m = splitTyConApp_maybe retTy
    monadTyCon <- thNameToTyCon monadTyConTH
    listTyCon' <- thNameToTyCon listTyConTH
    case retTyCon_m of
      Just (retTyCon, retTyArgs) -> do
        if length argTys == 1 && retTyCon == monadTyCon && length retTyArgs == 1
        then do
          let argTyCon_m = splitTyConApp_maybe $ head argTys
          case argTyCon_m of
            Just (argTyCon, argTyArgs) -> do
                let argTyArg = head argTyArgs
                let retTyArg = case splitTyConApp_maybe $ head retTyArgs of
                                  Just (rTyCon, []) -> mkTyConTy rTyCon
                                  Just (rTyCon, [retTyArg']) -> retTyArg'
                                  _                 -> head retTyArgs
                s' <- get
                put s' {funcId = [b]}

                let (lbs, e') = collectBinders e
                e'' <- recurSubExpr e'
                let arg = head lbs

                -- Build the step body of the While
                e'''  <- transformRecur argTyArg retTyArg e''
                newStepB <- buildId ("x") argTyArg
                stepE <- changeVarExpr arg newStepB e'''<commit_msg>Correct issue with Recursion pass and Expr [Word8] return.<commit_after>-------------------------------------------------------------------------------
-- |
-- Module      :  System.Hardware.Haskino.ShallowDeepPlugin.RecurPass
-- Copyright   :  (c) University of Kansas
-- License     :  BSD3
-- Stability   :  experimental
--
-- Recursion Transformation Pass
-------------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module System.Hardware.Haskino.ShallowDeepPlugin.RecurPass (recurPass) where

import Control.Monad.State
import CoreMonad
import GhcPlugins

import System.Hardware.Haskino.ShallowDeepPlugin.Utils

data BindEnv
    = BindEnv
      { pluginModGuts :: ModGuts,
        funcId        :: [Id]
      }

newtype BindM a = BindM { runBindM :: StateT BindEnv CoreM a }
    deriving (Functor, Applicative, Monad
             ,MonadIO, MonadState BindEnv)

instance PassCoreM BindM where
    liftCoreM m = BindM $ lift m
    getModGuts = gets pluginModGuts


recurPass :: ModGuts -> CoreM ModGuts
recurPass guts = do
    bindsL' <- (\x -> fst <$> (runStateT (runBindM $ (mapM recurBind) x) (BindEnv guts []))) (mg_binds guts)
    return (guts { mg_binds = concat bindsL' })

recurBind :: CoreBind -> BindM [CoreBind]
recurBind (NonRec b e) = do
    e' <- recurSubExpr e
    return [NonRec b e']
recurBind (Rec bs) = do
    (nonRec, bs') <- recurBind' bs
    return $ nonRec ++ [Rec bs']

recurBind' :: [(Id, CoreExpr)] -> BindM ([CoreBind],[(Id, CoreExpr)])
recurBind' [] = return ([],[])
recurBind' ((b, e) : bs) = do
    let defaultRet = do
          (nonrec, bs') <- recurBind' bs
          return $ (nonrec, (b, e) : bs')
    s <- get
    put s {funcId = [b]}
    let (argTys, retTy) = splitFunTys $ exprType e
    let retTyCon_m = splitTyConApp_maybe retTy
    monadTyCon <- thNameToTyCon monadTyConTH
    exprTyCon <- thNameToTyCon exprTyConTH
    listTyCon' <- thNameToTyCon listTyConTH
    case retTyCon_m of
      Just (retTyCon, retTyArgs) -> do
        if length argTys == 1 && retTyCon == monadTyCon && length retTyArgs == 1
        then do
          let argTyCon_m = splitTyConApp_maybe $ head argTys
          case argTyCon_m of
            Just (argTyCon, argTyArgs) -> do
                let argTyArg = head argTyArgs
                let retTyArg = case splitTyConApp_maybe $ head retTyArgs of
                                  Just (rTyCon, []) -> mkTyConTy rTyCon
                                  Just (rTyCon, [retTyArg']) | rTyCon == exprTyCon -> retTyArg'
                                  _                 -> head retTyArgs
                s' <- get
                put s' {funcId = [b]}

                let (lbs, e') = collectBinders e
                e'' <- recurSubExpr e'
                let arg = head lbs

                -- Build the step body of the While
                e'''  <- transformRecur argTyArg retTyArg e''
                newStepB <- buildId ("x") argTyArg
                stepE <- changeVarExpr arg newStepB e'''
{'fraction_non_alphanumeric': 0.15320704553007644, 'fraction_numerical': 0.001163177135260884, 'mean_word_length': 1.7852845904673762, 'pattern_counts': {'":': 0, '<': 30, '<?xml version=': 0, '>': 23, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 8, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '2887133', 'n_tokens_mistral': 1956, 'n_tokens_neox': 1855, 'n_words': 522}