ConstantFolding.hs

{-
 - Copyright (c) 2009-2010, ERICSSON AB All rights reserved.
 - 
 - Redistribution and use in source and binary forms, with or without
 - modification, are permitted provided that the following conditions
 - are met:
 - 
 -     * Redistributions of source code must retain the above copyright
 -     notice,
 -       this list of conditions and the following disclaimer.
 -     * Redistributions in binary form must reproduce the above copyright
 -       notice, this list of conditions and the following disclaimer
 -       in the documentation and/or other materials provided with the
 -       distribution.
 -     * Neither the name of the ERICSSON AB nor the names of its
 -     contributors
 -       may be used to endorse or promote products derived from this
 -       software without specific prior written permission.
 - 
 - THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 - "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 - LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 - A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 - HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
 - SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
 - LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 - DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 - THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 - (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
 - OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 -}

{-# LANGUAGE TypeFamilies #-}

module Feldspar.Compiler.Plugins.ConstantFolding where

import Feldspar.Compiler.PluginArchitecture

data ConstantFolding = ConstantFolding

instance Plugin ConstantFolding where
  type ExternalInfo ConstantFolding = ()
  executePlugin ConstantFolding _ procedure =
    fst $ executeTransformationPhase ConstantFolding () procedure

instance TransformationPhase ConstantFolding where
  type From ConstantFolding = ()
  type To ConstantFolding = ()
  type Downwards ConstantFolding = ()
  type Upwards ConstantFolding = ()

  transformFunctionCall ConstantFolding _ _ (InfosFromFunctionCallParts funData _) =
    case roleOfFunctionToCall $ funData of
      InfixOp -> case nameOfFunctionToCall $ funData of
        "+"     -> elimParamIf (isConstIntN 0) True funCall
        "-"     -> elimParamIf (isConstIntN 0) False funCall
        "*"     -> elimParamIf (isConstIntN 1) True funCall
        _       -> FunctionCallExpression funCall
      _       -> FunctionCallExpression funCall

    where
      funCall = FunctionCall (funData) ()

      isConstIntN n (ConstantExpression (IntConstant (IntConstantType i _))) = n == i
      isConstIntN _ _ = False

      elimParamIf pred flippable funCall@(FunctionCall (FunctionCallData InfixOp _ _ (x:xs)) _)
        | pred (head xs)      = x
        | flippable && pred x = head xs
        | otherwise           = FunctionCallExpression funCall
      elimParamIf _ _ funCall = FunctionCallExpression funCall