UnDict.hs

-- Dereferencing of dictionary-based calls in Hugs-produced Yhc Core.


module Yhc.Core.FrontEnd.Hugs.UnDict where

import Data.List
import Data.Maybe
import Yhc.Core.Extra

-- |Given function name, find out whether it is possibly a dictionary,
-- A successful candidate has zero arity and body consisting of only data constructor
-- applied to a saturating (>0) number of arguments. No let ... in, therefore all
-- constructor's arguments will point outside, no closures. If test is passed,
-- constructor name, and list of arguments will be returned, otherwise an empty
-- string and empty list will be returned.

possiblyDict :: Core -> CoreFuncName -> (CoreCtorName, [CoreExpr])

possiblyDict core fn = x
  where
    nodict = ("", [])
    unpos (CorePos _ e) = unpos e
    unpos e = e
    x = case coreFuncMaybe core fn of
      Just func@CoreFunc {coreFuncArgs = []} ->
        case unpos (coreFuncBody func) of
          CoreApp (CoreCon con) cargs -> 
            case coreCtorMaybe core con of
              Just CoreCtor {coreCtorFields = cfs} | length cargs == length cfs
                -> (con, cargs)
              _ -> nodict
          _ -> nodict
      _ -> nodict

-- |This function eliminates a "dictionary pattern". The dictionary pattern
-- is an application of a selector function to a dictionary (that is, selection
-- of a data field) where data field contains a function name or a constructor name.
-- Overloaded funcitons such as "Prelude.*" are in fact selectors from given dictionaries.
-- Applications of a selector function to a dictionary yields another function
-- which may or may not be a selector again, to be applied to the subsequent arguments.
-- Elimination of such pattern statically gives benefits of one runtime dereference 
-- removal, plus strictness analysis will be more accurate since strictness cannot 
-- be seen through dictionaries. It is recommended to apply the following transformations
-- to Core prior to this one: coreCaseElim . coreSimplify . unLiftCtors . removeRecursiveLet.

unDict :: Core -> Core

unDict core = transformExpr (f core) core where
  f core x@(CoreApp (CoreFun sel) ((CoreFun dict):rest)) = 
    let pblsel = coreSelectorIndex core sel
        pbldict = possiblyDict core dict
    in  case (pblsel, pbldict) of
          ((dctn, idx), (dctr, exprs))
            | null dctn || null dctr -> x
            | dctn /= dctr -> x
            | otherwise -> let e = exprs !! idx in case e of
                CoreCon _ -> CoreApp e rest
                CoreFun _ -> CoreApp e rest
                CoreApp y z -> CoreApp (f core e) rest
                _ -> x
  f core x@(CoreApp (CoreFun sel) [y]) = 
    let pblsel = coreSelectorIndex core sel
    in  case pblsel of
          (dctn, idx) | (not . null) dctn && idx >= 0 ->
                        CoreApp (CoreFun "SEL_ELEM") 
                                [CoreCon dctn, y, CoreLit $ CoreInt (idx + 1)]
                      | otherwise -> x
  f core x@(CoreApp (CoreFun sel) (y:ys)) = 
    let pblsel = coreSelectorIndex core sel
    in  case pblsel of
          (dctn, idx) | (not . null) dctn && idx >= 0 ->
                        CoreApp (CoreApp (CoreFun "SEL_ELEM") 
                                 [CoreCon dctn, y, CoreLit $ CoreInt (idx + 1)]) ys
                      | otherwise -> x

  f _ x = x