ReduceC.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module ReduceC (
  defaultReduceC,
  defaultReduceCWithKeywords,
  -- reduceCTranslUnit,

  -- * Context
  Context (..),
  defaultContext,

  -- * Helpers
  prettyIdent,
) where

import CType
import Control.Applicative
import Control.Monad
import qualified Control.Monad.IRTree as IRTree
import Control.Monad.Reduce
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.Function
import Data.Functor
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
import Debug.Pretty.Simple
import qualified Language.C as C
import qualified Language.C.Data.Ident as C
import qualified Language.C.Data.Node as C

defaultReduceCWithKeywords :: (MonadReduce (String, C.Position) m) => [Keyword] -> C.CTranslUnit -> m C.CTranslUnit
defaultReduceCWithKeywords keywords a = reduceCTranslUnit a (defaultContext{keywords = Set.fromList keywords})
{-# SPECIALIZE defaultReduceCWithKeywords :: [Keyword] -> C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}

defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.CTranslUnit
defaultReduceC a = reduceCTranslUnit a defaultContext
{-# SPECIALIZE defaultReduceC :: C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}

reduceCTranslUnit
  :: (MonadReduce Lab m)
  => C.CTranslationUnit C.NodeInfo
  -> Context
  -> m (C.CTranslationUnit C.NodeInfo)
reduceCTranslUnit (C.CTranslUnit es ni) ctx = do
  (_functions, _structs) <- flip evalState ctx do
    (fs, sts) <- flip mapAndUnzipM es \e -> do
      includeTypeDef e
      funcs <- gets \ctx' -> findFunctions (: []) ctx' e
      structs <- state \ctx' ->
        let ss = findStructs (: []) ctx' e
         in ( ss
            , ctx'
                { structs =
                    foldr
                      ( \s ->
                          Map.insert (structName s) (structType s, Nothing)
                      )
                      (structs ctx')
                      ss
                }
            )

      pure (funcs, structs)
    pure (pure (concat fs, concat sts))

  let funmap :: [(C.Ident, Maybe Function)] =
        List.sortOn (maybe 0 (negate . funSize) . snd)
          . Map.toList
          . Map.fromListWith const
          . map (\f -> (funName f, Just f))
          . List.sortOn funSize
          $ _functions

  let reduce funcs = forM funcs \(k, mf) ->
        (k,) <$> runMaybeT do
          f <- liftMaybe mf
          let fstr = C.identToString (funName f)
          when (C.identToString (funName f) /= "main" || LoseMain `isIn` ctx) do
            exceptIf ("remove function " <> fstr <> " (" <> show (funSize f) <> ")", funPosition f)
          isStatic <-
            if funIsStatic f
              then
                split
                  ("remove static from " <> fstr, funPosition f)
                  (pure False)
                  (pure True)
              else pure False
          pure f{funIsStatic = isStatic}

  -- try remove static
  functions2 <- do
    funmap' <- reduce funmap
    if ComputeFunctionFixpoint `isIn` ctx
      then reduce funmap
      else pure funmap'

  functions3 <- forM functions2 \(k, mf) ->
    (k,) <$> runMaybeT do
      f <- liftMaybe mf
      let FunType rtype rparams = funType f
      params <- case rparams of
        Params params False -> do
          params' <- forM params \p -> runMaybeT do
            p' <- liftMaybe p
            exceptIf ("remove parameter", funPosition f)
            pure p'
          pure (Params params' False)
        ow -> pure ow
      pure f{funType = FunType rtype params}

  let functions''' =
        Map.fromList $
          functions3
            <> [ ( funName
                 , Just $
                    Function
                      { funIsStatic = False
                      , funPosition = C.posOf funName
                      , funSize = 0
                      , ..
                      }
                 )
               | (C.builtinIdent -> funName, funReturns, funParams) <-
                  [ ("fabsf", NonVoid TNum, Params [Just TNum] False)
                  , ("fabs", NonVoid TNum, Params [Just TNum] False)
                  ]
               , let funType = FunType funReturns funParams
               ]

  structs' <- flip execStateT (structs ctx) do
    forM_ _structs \s -> do
      let sstr = C.identToString (structName s)
      ms <- runMaybeT do
        exceptIf ("remove struct " <> show sstr, structPosition s)
        pure s
      modify' (Map.insert (structName s) (structType s, ms))

  let ctx' = ctx{functions = functions''', structs = structs'}
  res' <- evalStateT (mapM reduceCExternalDeclaration es) ctx'
  pure $ C.CTranslUnit (catMaybes res') ni

reduceCExternalDeclaration
  :: (HasCallStack, MonadReduce Lab m)
  => C.CExternalDeclaration C.NodeInfo
  -> StateT Context m (Maybe (C.CExternalDeclaration C.NodeInfo))
reduceCExternalDeclaration r = case r of
  C.CFDefExt (C.CFunDef spec declr [] stmt ni) -> runMaybeT do
    ctx <- get

    let C.CDeclr mid dd Nothing [] ni2 = declr
    let (C.CFunDeclr (C.CFunParamsNew params b) attr ni3 : dd') = dd

    (FunType rtype pFilter, spec') <- case mid of
      Just fid -> do
        modify' (addInlineExpr fid IEDelete)
        guard (not $ any (shouldDeleteDeclSpec ctx) spec)
        f <- liftMaybe (lookupFunction ctx fid)
        modify' (addInlineExpr fid (IEKeep (TFun $ funType f)))
        pure (funType f, filterStorageModifiers (funIsStatic f) spec)
      Nothing -> do
        let TFun ft = nonVoidTypeOfFromContext ctx spec declr
        exceptIf ("remove function", C.posOf r)
        pure (ft, spec)

    let (params', idents) = case pFilter of
          Params flt False -> filterParams ctx flt params
          _ow -> (params, [])

    labs <- flip collect (labelsOf stmt) \l -> do
      exceptIf ("remove label" <> show l, C.posOf l)
      pure l

    stmt' <-
      reduceCStatementOrEmptyBlock stmt StmtContext{stmtLabels = labs, stmtInLoop = False} $
        (foldr (uncurry addInlineExpr) ctx idents){returnType = rtype}

    let dd'' = C.CFunDeclr (C.CFunParamsNew params' b) attr ni3 : dd'

    pure . C.CFDefExt $
      C.CFunDef
        (inlineTypeDefsSpecs spec' ctx)
        (inlineTypeDefsCDeclarator (C.CDeclr mid dd'' Nothing [] ni2) ctx)
        []
        stmt'