path: root/ghc/compiler/prelude/PrelRules.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[ConFold]{Constant Folder}

Conceptually, constant folding should be parameterized with the kind
of target machine to get identical behaviour during compilation time
and runtime. We cheat a little bit here...

ToDo:
   check boundaries before folding, e.g. we can fold the Float addition
   (i1 + i2) only if it results	in a valid Float.

\begin{code}
module PrelRules ( primOpRule, builtinRules ) where

#include "HsVersions.h"

import CoreSyn
import Id		( mkWildId )
import Literal		( Literal(..), isLitLitLit, mkMachInt, mkMachWord
			, literalType
			, word2IntLit, int2WordLit
			, intToInt8Lit, intToInt16Lit, intToInt32Lit
			, wordToWord8Lit, wordToWord16Lit, wordToWord32Lit
			, char2IntLit, int2CharLit
			, float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit
			, addr2IntLit, int2AddrLit, float2DoubleLit, double2FloatLit
			)
import PrimOp		( PrimOp(..), primOpOcc )
import TysWiredIn	( trueDataConId, falseDataConId )
import TyCon		( tyConDataConsIfAvailable, isEnumerationTyCon, isNewTyCon )
import DataCon		( dataConTag, dataConTyCon, dataConId, fIRST_TAG )
import CoreUtils	( exprIsValue, cheapEqExpr, exprIsConApp_maybe )
import Type		( tyConAppTyCon, eqType )
import OccName		( occNameUserString)
import PrelNames	( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey )
import Name		( Name )
import Bits		( Bits(..) )
#if __GLASGOW_HASKELL__ >= 500
import Word		( Word )
#else
import Word		( Word64 )
#endif
import Outputable
import CmdLineOpts      ( opt_SimplExcessPrecision )
\end{code}


\begin{code}
primOpRule :: PrimOp -> Maybe CoreRule
primOpRule op = fmap BuiltinRule (primop_rule op)
  where
    op_name = _PK_ (occNameUserString (primOpOcc op))
    op_name_case = op_name _APPEND_ SLIT("->case")

    -- ToDo:	something for integer-shift ops?
    --		NotOp

    primop_rule SeqOp	    = Just seqRule
    primop_rule TagToEnumOp = Just tagToEnumRule
    primop_rule DataToTagOp = Just dataToTagRule

	-- Int operations
    primop_rule IntAddOp    = Just (twoLits (intOp2     (+)   op_name))
    primop_rule IntSubOp    = Just (twoLits (intOp2     (-)   op_name))
    primop_rule IntMulOp    = Just (twoLits (intOp2     (*)   op_name))
    primop_rule IntQuotOp   = Just (twoLits (intOp2Z    quot  op_name))
    primop_rule IntRemOp    = Just (twoLits (intOp2Z    rem   op_name))
    primop_rule IntNegOp    = Just (oneLit  (negOp            op_name))

	-- Word operations
#if __GLASGOW_HASKELL__ >= 500
    primop_rule WordAddOp   = Just (twoLits (wordOp2    (+)   op_name))
    primop_rule WordSubOp   = Just (twoLits (wordOp2    (-)   op_name))
    primop_rule WordMulOp   = Just (twoLits (wordOp2    (*)   op_name))
#endif
    primop_rule WordQuotOp  = Just (twoLits (wordOp2Z   quot  op_name))
    primop_rule WordRemOp   = Just (twoLits (wordOp2Z   rem   op_name))
#if __GLASGOW_HASKELL__ >= 407
    primop_rule AndOp       = Just (twoLits (wordBitOp2 (.&.) op_name))
    primop_rule OrOp        = Just (twoLits (wordBitOp2 (.|.) op_name))
    primop_rule XorOp       = Just (twoLits (wordBitOp2 xor   op_name))
#endif

	-- coercions
    primop_rule Word2IntOp 	= Just (oneLit (litCoerce word2IntLit     op_name))
    primop_rule Int2WordOp 	= Just (oneLit (litCoerce int2WordLit     op_name))
    primop_rule IntToInt8Op 	= Just (oneLit (litCoerce intToInt8Lit    op_name))
    primop_rule IntToInt16Op 	= Just (oneLit (litCoerce intToInt16Lit   op_name))
    primop_rule IntToInt32Op 	= Just (oneLit (litCoerce intToInt32Lit   op_name))
    primop_rule WordToWord8Op 	= Just (oneLit (litCoerce wordToWord8Lit  op_name))
    primop_rule WordToWord16Op 	= Just (oneLit (litCoerce wordToWord16Lit op_name))
    primop_rule WordToWord32Op 	= Just (oneLit (litCoerce wordToWord32Lit op_name))
    primop_rule OrdOp   	= Just (oneLit (litCoerce char2IntLit     op_name))
    primop_rule ChrOp    	= Just (oneLit (litCoerce int2CharLit     op_name))
    primop_rule Float2IntOp	= Just (oneLit (litCoerce float2IntLit    op_name))
    primop_rule Int2FloatOp	= Just (oneLit (litCoerce int2FloatLit    op_name))
    primop_rule Double2IntOp	= Just (oneLit (litCoerce double2IntLit   op_name))
    primop_rule Int2DoubleOp	= Just (oneLit (litCoerce int2DoubleLit   op_name))
    primop_rule Addr2IntOp 	= Just (oneLit (litCoerce addr2IntLit     op_name))
    primop_rule Int2AddrOp 	= Just (oneLit (litCoerce int2AddrLit     op_name))
	-- SUP: Not sure what the standard says about precision in the following 2 cases
    primop_rule Float2DoubleOp 	= Just (oneLit (litCoerce float2DoubleLit op_name))
    primop_rule Double2FloatOp 	= Just (oneLit (litCoerce double2FloatLit op_name))

	-- Float
    primop_rule FloatAddOp   = Just (twoLits (floatOp2  (+) op_name))
    primop_rule FloatSubOp   = Just (twoLits (floatOp2  (-) op_name))
    primop_rule FloatMulOp   = Just (twoLits (floatOp2  (*) op_name))
    primop_rule FloatDivOp   = Just (twoLits (floatOp2Z (/) op_name))
    primop_rule FloatNegOp   = Just (oneLit  (negOp op_name))

	-- Double
    primop_rule DoubleAddOp   = Just (twoLits (doubleOp2  (+) op_name))
    primop_rule DoubleSubOp   = Just (twoLits (doubleOp2  (-) op_name))
    primop_rule DoubleMulOp   = Just (twoLits (doubleOp2  (*) op_name))
    primop_rule DoubleDivOp   = Just (twoLits (doubleOp2Z (/) op_name))
    primop_rule DoubleNegOp   = Just (oneLit  (negOp op_name))

	-- Relational operators
    primop_rule IntEqOp  = Just (relop (==) `or_rule` litEq True  op_name_case)
    primop_rule IntNeOp  = Just (relop (/=) `or_rule` litEq False op_name_case)
    primop_rule CharEqOp = Just (relop (==) `or_rule` litEq True  op_name_case)
    primop_rule CharNeOp = Just (relop (/=) `or_rule` litEq False op_name_case)

    primop_rule IntGtOp		= Just (relop (>))
    primop_rule IntGeOp		= Just (relop (>=))
    primop_rule IntLeOp		= Just (relop (<=))
    primop_rule IntLtOp		= Just (relop (<))

    primop_rule CharGtOp	= Just (relop (>))
    primop_rule CharGeOp	= Just (relop (>=))
    primop_rule CharLeOp	= Just (relop (<=))
    primop_rule CharLtOp	= Just (relop (<))

    primop_rule FloatGtOp	= Just (relop (>))
    primop_rule FloatGeOp	= Just (relop (>=))
    primop_rule FloatLeOp	= Just (relop (<=))
    primop_rule FloatLtOp	= Just (relop (<))
    primop_rule FloatEqOp	= Just (relop (==))
    primop_rule FloatNeOp	= Just (relop (/=))

    primop_rule DoubleGtOp	= Just (relop (>))
    primop_rule DoubleGeOp	= Just (relop (>=))
    primop_rule DoubleLeOp	= Just (relop (<=))
    primop_rule DoubleLtOp	= Just (relop (<))
    primop_rule DoubleEqOp	= Just (relop (==))
    primop_rule DoubleNeOp	= Just (relop (/=))

    primop_rule WordGtOp	= Just (relop (>))
    primop_rule WordGeOp	= Just (relop (>=))
    primop_rule WordLeOp	= Just (relop (<=))
    primop_rule WordLtOp	= Just (relop (<))
    primop_rule WordEqOp	= Just (relop (==))
    primop_rule WordNeOp	= Just (relop (/=))

    primop_rule other		= Nothing


    relop cmp = twoLits (cmpOp (\ord -> ord `cmp` EQ) op_name)
	-- Cunning.  cmpOp compares the values to give an Ordering.
	-- It applies its argument to that ordering value to turn
	-- the ordering into a boolean value.  (`cmp` EQ) is just the job.
\end{code}

%************************************************************************
%*									*
\subsection{Doing the business}
%*									*
%************************************************************************

	IMPORTANT NOTE

In all these operations we might find a LitLit as an operand; that's
why we have the catch-all Nothing case.

\begin{code}
--------------------------
litCoerce :: (Literal -> Literal) -> RuleName -> Literal -> Maybe (RuleName, CoreExpr)
litCoerce fn name lit | isLitLitLit lit = Nothing
                      | otherwise       = Just (name, Lit (fn lit))

--------------------------
cmpOp :: (Ordering -> Bool) -> FAST_STRING -> Literal -> Literal -> Maybe (RuleName, CoreExpr)
cmpOp cmp name l1 l2
  = go l1 l2
  where
    done res | cmp res = Just (name, trueVal)
	     | otherwise    = Just (name, falseVal)

	-- These compares are at different types
    go (MachChar i1)   (MachChar i2)   = done (i1 `compare` i2)
    go (MachInt i1)    (MachInt i2)    = done (i1 `compare` i2)
    go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `compare` i2)
    go (MachWord i1)   (MachWord i2)   = done (i1 `compare` i2)
    go (MachWord64 i1) (MachWord64 i2) = done (i1 `compare` i2)
    go (MachFloat i1)  (MachFloat i2)  = done (i1 `compare` i2)
    go (MachDouble i1) (MachDouble i2) = done (i1 `compare` i2)
    go l1	       l2	       = Nothing

--------------------------

negOp name (MachFloat f)  = Just (name, mkFloatVal (-f))
negOp name (MachDouble d) = Just (name, mkDoubleVal (-d))
negOp name (MachInt i)    = intResult name (-i)
negOp name l		  = Nothing

--------------------------
intOp2 op name (MachInt i1) (MachInt i2)
  = intResult name (i1 `op` i2)
intOp2 op name l1 l2 = Nothing		-- Could find LitLit

intOp2Z op name (MachInt i1) (MachInt i2)
  | i2 /= 0 = Just (name, mkIntVal (i1 `op` i2))
intOp2Z op name l1 l2 = Nothing		-- LitLit or zero dividend

--------------------------
#if __GLASGOW_HASKELL__ >= 500
wordOp2 op name (MachWord w1) (MachWord w2)
  = wordResult name (w1 `op` w2)
wordOp2 op name l1 l2 = Nothing		-- Could find LitLit
#endif

wordOp2Z op name (MachWord w1) (MachWord w2)
  | w2 /= 0 = Just (name, mkWordVal (w1 `op` w2))
wordOp2Z op name l1 l2 = Nothing	-- LitLit or zero dividend

#if __GLASGOW_HASKELL__ >= 500
wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2)
  = Just (name, mkWordVal (w1 `op` w2))
#else
-- Integer is not an instance of Bits, so we operate on Word64
wordBitOp2 op name l1@(MachWord w1) l2@(MachWord w2)
  = Just (name, mkWordVal ((fromIntegral::Word64->Integer) (fromIntegral w1 `op` fromIntegral w2)))
#endif
wordBitOp2 op name l1 l2 = Nothing		-- Could find LitLit

--------------------------
floatOp2  op name (MachFloat f1) (MachFloat f2)
  = Just (name, mkFloatVal (f1 `op` f2))
floatOp2  op name l1 l2 = Nothing

floatOp2Z op name (MachFloat f1) (MachFloat f2)
  | f2 /= 0   = Just (name, mkFloatVal (f1 `op` f2))
floatOp2Z op name l1 l2 = Nothing

--------------------------
doubleOp2  op name (MachDouble f1) (MachDouble f2)
  = Just (name, mkDoubleVal (f1 `op` f2))
doubleOp2 op name l1 l2 = Nothing

doubleOp2Z op name (MachDouble f1) (MachDouble f2)
  | f2 /= 0   = Just (name, mkDoubleVal (f1 `op` f2))
doubleOp2Z op name l1 l2 = Nothing


--------------------------
	-- This stuff turns
	--	n ==# 3#
	-- into
	--	case n of
	--	  3# -> True
	--	  m  -> False
	--
	-- This is a Good Thing, because it allows case-of case things
	-- to happen, and case-default absorption to happen.  For
	-- example:
	--
	--	if (n ==# 3#) || (n ==# 4#) then e1 else e2
	-- will transform to
	--	case n of
	--	  3# -> e1
	--	  4# -> e1
	--	  m  -> e2
	-- (modulo the usual precautions to avoid duplicating e1)

litEq :: Bool		-- True <=> equality, False <=> inequality
        -> RuleName
	-> RuleFun
litEq is_eq name [Lit lit, expr] = do_lit_eq is_eq name lit expr
litEq is_eq name [expr, Lit lit] = do_lit_eq is_eq name lit expr
litEq is_eq name other		 = Nothing

do_lit_eq is_eq name lit expr
  = Just (name, Case expr (mkWildId (literalType lit))
		     [(DEFAULT,    [], val_if_neq),
		      (LitAlt lit, [], val_if_eq)])
  where
    val_if_eq  | is_eq     = trueVal
	       | otherwise = falseVal
    val_if_neq | is_eq     = falseVal
	       | otherwise = trueVal

-- Note that we *don't* warn the user about overflow. It's not done at
-- runtime either, and compilation of completely harmless things like
--    ((124076834 :: Word32) + (2147483647 :: Word32))
-- would yield a warning. Instead we simply squash the value into the
-- Int range, but not in a way suitable for cross-compiling... :-(
intResult :: RuleName -> Integer -> Maybe (RuleName, CoreExpr)
intResult name result
  = Just (name, mkIntVal (toInteger (fromInteger result :: Int)))

#if __GLASGOW_HASKELL__ >= 500
wordResult :: RuleName -> Integer -> Maybe (RuleName, CoreExpr)
wordResult name result
  = Just (name, mkWordVal (toInteger (fromInteger result :: Word)))
#endif
\end{code}


%************************************************************************
%*									*
\subsection{Vaguely generic functions
%*									*
%************************************************************************

\begin{code}
type RuleFun = [CoreExpr] -> Maybe (RuleName, CoreExpr)

or_rule :: RuleFun -> RuleFun -> RuleFun
or_rule r1 r2 args = maybe (r2 args) Just (r1 args) -- i.e.: r1 args `mplus` r2 args

twoLits :: (Literal -> Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
twoLits rule [Lit l1, Lit l2] = rule (convFloating l1) (convFloating l2)
twoLits rule _                = Nothing

oneLit :: (Literal -> Maybe (RuleName, CoreExpr)) -> RuleFun
oneLit rule [Lit l1] = rule (convFloating l1)
oneLit rule _        = Nothing

-- When excess precision is not requested, cut down the precision of the
-- Rational value to that of Float/Double. We confuse host architecture
-- and target architecture here, but it's convenient (and wrong :-).
convFloating :: Literal -> Literal
convFloating (MachFloat  f) | not opt_SimplExcessPrecision =
   MachFloat  (toRational ((fromRational f) :: Float ))
convFloating (MachDouble d) | not opt_SimplExcessPrecision =
   MachDouble (toRational ((fromRational d) :: Double))
convFloating l = l


trueVal       = Var trueDataConId
falseVal      = Var falseDataConId
mkIntVal    i = Lit (mkMachInt  i)
mkWordVal   w = Lit (mkMachWord w)
mkFloatVal  f = Lit (convFloating (MachFloat  f))
mkDoubleVal d = Lit (convFloating (MachDouble d))
\end{code}

						
%************************************************************************
%*									*
\subsection{Special rules for seq, tagToEnum, dataToTag}
%*									*
%************************************************************************

In the parallel world, we use _seq_ to control the order in which
certain expressions will be evaluated.  Operationally, the expression
``_seq_ a b'' evaluates a and then evaluates b.  We have an inlining
for _seq_ which translates _seq_ to:

   _seq_ = /\ a b -> \ x::a y::b -> case seq# x of { 0# -> parError#; _ -> y }

Now, we know that the seq# primitive will never return 0#, but we
don't let the simplifier know that.  We also use a special error
value, parError#, which is *not* a bottoming Id, so as far as the
simplifier is concerned, we have to evaluate seq# a before we know
whether or not y will be evaluated.

If we didn't have the extra case, then after inlining the compiler might
see:
	f p q = case seq# p of { _ -> p+q }

If it sees that, it can see that f is strict in q, and hence it might
evaluate q before p!  The "0# ->" case prevents this happening.
By having the parError# branch we make sure that anything in the
other branch stays there!

This is fine, but we'd like to get rid of the extraneous code.  Hence,
we *do* let the simplifier know that seq# is strict in its argument.
As a result, we hope that `a' will be evaluated before seq# is called.
At this point, we have a very special and magical simpification which
says that ``seq# a'' can be immediately simplified to `1#' if we
know that `a' is already evaluated.

NB: If we ever do case-floating, we have an extra worry:

    case a of
      a' -> let b' = case seq# a of { True -> b; False -> parError# }
	    in case b' of ...

    =>

    case a of
      a' -> let b' = case True of { True -> b; False -> parError# }
	    in case b' of ...

    =>

    case a of
      a' -> let b' = b
	    in case b' of ...

    =>

    case a of
      a' -> case b of ...

The second case must never be floated outside of the first!

\begin{code}
seqRule [Type ty, arg] | exprIsValue arg = Just (SLIT("Seq"), mkIntVal 1)
seqRule other				 = Nothing
\end{code}


\begin{code}
tagToEnumRule [Type ty, Lit (MachInt i)]
  = ASSERT( isEnumerationTyCon tycon ) 
    case filter correct_tag (tyConDataConsIfAvailable tycon) of


	[]	  -> Nothing	-- Abstract type
	(dc:rest) -> ASSERT( null rest )
		     Just (SLIT("TagToEnum"), Var (dataConId dc))
  where 
    correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
    tag   = fromInteger i
    tycon = tyConAppTyCon ty

tagToEnumRule other = Nothing
\end{code}

For dataToTag#, we can reduce if either 
	
	(a) the argument is a constructor
	(b) the argument is a variable whose unfolding is a known constructor

\begin{code}
dataToTagRule [_, val_arg]
  = case exprIsConApp_maybe val_arg of
	Just (dc,_) -> ASSERT( not (isNewTyCon (dataConTyCon dc)) )
	     	       Just (SLIT("DataToTag"), 
		   	     mkIntVal (toInteger (dataConTag dc - fIRST_TAG)))

	other	    -> Nothing

dataToTagRule other = Nothing
\end{code}

%************************************************************************
%*									*
\subsection{Built in rules}
%*									*
%************************************************************************

\begin{code}
builtinRules :: [(Name, CoreRule)]
-- Rules for non-primops that can't be expressed using a RULE pragma
builtinRules
  = [ (unpackCStringFoldrName, BuiltinRule match_append_lit_str)
    ]


-- The rule is this:
-- 	unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)  =  unpackFoldrCString# "foobaz" c n

match_append_lit_str [Type ty1,
		      Lit (MachStr s1),
		      c1,
		      Var unpk `App` Type ty2 
			       `App` Lit (MachStr s2)
			       `App` c2
			       `App` n
		     ]
  | unpk `hasKey` unpackCStringFoldrIdKey && 
    c1 `cheapEqExpr` c2
  = ASSERT( ty1 `eqType` ty2 )
    Just (SLIT("AppendLitString"),
	  Var unpk `App` Type ty1
		   `App` Lit (MachStr (s1 _APPEND_ s2))
		   `App` c1
		   `App` n)

match_append_lit_str other = Nothing
\end{code}