Re: object code blow up by optimization

Simon Peyton-Jones wrote:
> Just to let you know, I can reproduce this problem nicely (thank you for
> setting up the repro case).  It turns out to be caused by the
> simplifier's inlining policy which goes if not exponential then
> something very like it.  It's made dramatically worse by the fact that
> $$ and <+> are left-associative.  If you change them to right-assoc the
> problem disappears I think.

Thanks, for looking into it. For our code bloat, related to the 
ShATermConvertible instances, there are no associative operations. I've 
included the basic class and a few instances that pose no problem until 
very late in our final big binary (with many more instances).

Currently, I simply set "-fvia-C -O0" in parts of our code and hope that 
-optc-O1 helps a bit.

Cheers Christian

P.S. I've changed infixl to infixr
infixr 6 <>
infixr 6 <+>
infixr 5 $$, $+$

Not much difference in code size but a bit faster compared to the 
numbers I've posted before:

http://hackage.haskell.org/trac/ghc/ticket/490

Linking ...

real    7m37.899s
user    6m45.562s
sys     0m11.161s

maeder@turing:~/haskell/examples> ll a.out HasCASL/PrintLe.o
-rwxr-xr-x  1 maeder wimi 6468124 2006-01-26 19:48 a.out
-rw-r--r--  1 maeder wimi 2010772 2006-01-26 19:46 HasCASL/PrintLe.o

{- |
Module      :  $Header: /repository/HetCATS/Common/ATerm/AbstractSyntax.hs,v 
1.33 2006/01/20 13:27:46 2maeder Exp $
Copyright   :  (c) Klaus Lüttich, C. Maeder, Uni Bremen 2002-2006
License     :  similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

Maintainer  :  maeder@xxxxxx
Stability   :  provisional
Portability :  non-portable(imports System.Mem.StableName and GHC.Prim)

data types and utilities for shared ATerms and the ATermTable
-}

module Common.ATerm.AbstractSyntax
    (ShATerm(..),
     ATermTable,
     emptyATermTable,
     addATerm,
     getATerm, toReadonlyATT,
     getTopIndex,
     getATerm', setATerm', getShATerm,
     Key(..), newATermTable, getKey, setKey, mkKey,
     getATermByIndex1, str2Char, integer2Int
    ) where

import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import Data.Dynamic
import Data.Array
import System.Mem.StableName
import GHC.Prim
import qualified Data.List as List
import Data.Maybe

data ShATerm = ShAAppl String [Int] [Int]
             | ShAList [Int]        [Int]
             | ShAInt  Integer      [Int]
               deriving (Eq, Ord)

data IntMap = Updateable !(IntMap.IntMap ShATerm)
            | Readonly !(Array Int ShATerm)

empty :: IntMap
empty = Updateable $ IntMap.empty

insert :: Int -> ShATerm -> IntMap -> IntMap
insert i s t = case t of
    Updateable m -> Updateable $ IntMap.insert i s m
    _ -> error "ATerm.insert"

find :: Int -> IntMap -> ShATerm
find i t = case t of
    Updateable m -> IntMap.findWithDefault (ShAInt (-1) []) i m
    Readonly a -> a ! i

data EqKey = EqKey (StableName ()) TypeRep deriving Eq

data Key = Key Int EqKey

mkKey :: Typeable a => a -> IO Key
mkKey t = do
    s <- makeStableName t
    return $ Key (hashStableName s) $ EqKey (unsafeCoerce# s) $ typeOf t

data ATermTable = ATT
    (IntMap.IntMap [(EqKey, Int)])
    !(Map.Map ShATerm Int) !IntMap Int
    !(IntMap.IntMap [Dynamic])

toReadonlyATT :: ATermTable -> ATermTable
toReadonlyATT (ATT h s t i dM) = ATT h s
    (case t of
     Updateable m -> Readonly $ listArray (0, i) $ IntMap.elems m
     _ -> t ) i dM

emptyATermTable :: ATermTable
emptyATermTable = ATT IntMap.empty Map.empty empty (-1) IntMap.empty

newATermTable :: IO ATermTable
newATermTable = return $ emptyATermTable

addATermNoFullSharing :: ShATerm -> ATermTable -> (ATermTable, Int)
addATermNoFullSharing t (ATT h a_iDFM i_aDFM i1 dM) = let j = i1 + 1 in
    (ATT h (Map.insert t j a_iDFM) (insert j t i_aDFM) j dM, j)

addATerm :: ShATerm -> ATermTable -> (ATermTable, Int)
addATerm t at@(ATT _ a_iDFM _ _ _) =
  case Map.lookup t a_iDFM of
    Nothing -> addATermNoFullSharing t at
    Just i -> (at, i)

setKey :: Key -> Int -> ATermTable -> IO (ATermTable, Int)
setKey (Key h e) i (ATT t s l m d) =
    return (ATT (IntMap.insertWith (++) h [(e, i)] t) s l m d, i)

getKey :: Key -> ATermTable -> IO (Maybe Int)
getKey (Key h k) (ATT t _ _ _ _) =
    return $ List.lookup k $ IntMap.findWithDefault [] h t

getATerm :: ATermTable -> ShATerm
getATerm (ATT _ _ i_aFM i _) = find i i_aFM

getShATerm :: Int -> ATermTable -> ShATerm
getShATerm i (ATT _ _ i_aFM _ _) = find i i_aFM

getTopIndex :: ATermTable -> Int
getTopIndex (ATT _ _ _ i _) = i

getATermByIndex1 :: Int -> ATermTable -> ATermTable
getATermByIndex1 i (ATT h a_iDFM i_aDFM _ dM) = ATT h a_iDFM i_aDFM i dM

getATerm' :: Typeable t => Int -> ATermTable -> Maybe t
getATerm' i (ATT _ _ _ _ dM) =
    listToMaybe $ mapMaybe fromDynamic $ IntMap.findWithDefault [] i dM

setATerm' :: Typeable t => Int -> t -> ATermTable -> ATermTable
setATerm' i t (ATT h a_iDFM i_aDFM m dM) =
    ATT h a_iDFM i_aDFM m $ IntMap.insertWith (++) i [toDyn t] dM

-- | conversion of a string in double quotes to a character
str2Char :: String -> Char
str2Char ('\"' : sr) = conv' (init sr) where
                               conv' [x] = x
                               conv' ['\\', x] = case x of
                                   'n'  -> '\n'
                                   't'  -> '\t'
                                   'r'  -> '\r'
                                   '\"' -> '\"'
                                   _    -> error "strToChar"
                               conv' _ = error "String not convertible to char"
str2Char _         = error "String doesn't begin with '\"'"

-- | conversion of an unlimited integer to a machine int
integer2Int :: Integer -> Int
integer2Int x = if toInteger ((fromInteger :: Integer -> Int) x) == x
                  then fromInteger x
                  else error $ "Integer to big for Int: " ++ show x
{- |
Module      :  $Header: /repository/HetCATS/Common/ATerm/Conversion.hs,v 1.33 
2006/01/11 16:00:17 2maeder Exp $
Copyright   :  (c) Klaus Lüttich, C. Maeder, Uni Bremen 2002-2006
License     :  similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

Maintainer  :  maeder@xxxxxx
Stability   :  provisional
Portability :  non-portable(imports AbstractSyntax)

the class ShATermConvertible and a few instances
-}

module Common.ATerm.Conversion where

import Common.ATerm.AbstractSyntax
import Data.Typeable
import Data.List (mapAccumL)
import Data.Ratio
import Control.Monad

class Typeable t => ShATermConvertible t where
    -- functions for conversion to an ATermTable
    toShATermAux    :: ATermTable -> t -> IO (ATermTable, Int)
    toShATermList'  :: ATermTable -> [t] -> IO (ATermTable, Int)
    fromShATermAux  :: Int -> ATermTable -> (ATermTable, t)
    fromShATermList' :: Int -> ATermTable -> (ATermTable, [t])

    -- default functions ignore the Annotation part
    toShATermList' att ts = do
           (att2, inds) <- foldM (\ (att0, l) t -> do
                    (att1, i) <- toShATerm' att0 t
                    return (att1, i : l)) (att, []) ts
           return $ addATerm (ShAList (reverse inds) []) att2

    fromShATermList' ix att0 =
        case getShATerm ix att0 of
            ShAList ats _ ->
                mapAccumL (flip fromShATerm') att0 ats
            u -> fromShATermError "[]" u

toShATerm' :: ShATermConvertible t => ATermTable -> t -> IO (ATermTable, Int)
toShATerm' att t = do
       k <- mkKey t
       m <- getKey k att
       case m of
         Nothing -> do
           (att1, i) <- toShATermAux att t
           setKey k i att1
         Just i -> return (att, i)

fromShATerm' :: ShATermConvertible t => Int -> ATermTable -> (ATermTable, t)
fromShATerm' i att = case getATerm' i att of
        Just d -> (att, d)
        _ -> case fromShATermAux i att of
               (attN, t) -> (setATerm' i t attN, t)

fromShATermError :: String -> ShATerm -> a
fromShATermError t u = error $ "Cannot convert ShATerm to "
                       ++ t ++ ": " ++ err u
    where err te = case te of
                  ShAAppl s l _ -> "!ShAAppl "++ s
                                   ++ " (" ++ show (length l) ++ ")"
                  ShAList l _   -> "!ShAList"
                                   ++ " (" ++ show (length l) ++ ")"
                  ShAInt i _    -> "!ShAInt " ++ show i

-- some instances -----------------------------------------------
instance ShATermConvertible Bool where
    toShATermAux att b = return $ case b of
                       True  -> addATerm (ShAAppl "T" [] []) att
                       False -> addATerm (ShAAppl "F" [] []) att
    fromShATermAux ix att0 = case getShATerm ix att0 of
            ShAAppl "T" [] _ -> (att0, True)
            ShAAppl "F" [] _ -> (att0, False)
            u -> fromShATermError "Prelude.Bool" u

instance ShATermConvertible Integer where
    toShATermAux att x = return $ addATerm (ShAInt x []) att
    fromShATermAux ix att0 =
         case getShATerm ix att0 of
            ShAInt x _ -> (att0, x)
            u -> fromShATermError "Prelude.Integer" u

instance ShATermConvertible Int where
    toShATermAux att x = toShATermAux att (toInteger x)
    fromShATermAux ix att0 = case getShATerm ix att0 of
            ShAInt x _ -> (att0, integer2Int x)
            u -> fromShATermError "Prelude.Int" u

instance (ShATermConvertible a, Integral a)
    => ShATermConvertible (Ratio a) where
    toShATermAux att0 i = let (i1, i2) = (numerator i, denominator i) in do
       (att1,i1') <- toShATerm' att0 i1
       (att2,i2') <- toShATerm' att1 i2
       return $ addATerm (ShAAppl "Ratio" [i1',i2'] []) att2
    fromShATermAux ix att0 =
        case getShATerm ix att0 of
            ShAAppl "Ratio" [a,b] _ ->
                    case fromShATerm' a att0 of { (att1, a') ->
                    case fromShATerm' b att1 of { (att2, b') ->
                    (att2, a' %  b') }}
            u -> fromShATermError "Prelude.Integral" u

instance ShATermConvertible Char where
    toShATermAux att c = return $ addATerm (ShAAppl (show [c]) [] []) att
    fromShATermAux ix att0 = case getShATerm ix att0 of
            ShAAppl s [] _ -> (att0, str2Char s)
            u -> fromShATermError "Prelude.Char" u
    toShATermList' att s = return $ addATerm (ShAAppl (show s) [] []) att
    fromShATermList' ix att0 =
        case getShATerm ix att0 of
            ShAAppl s [] _ -> (att0, read s)
            u -> fromShATermError "Prelude.String" u

instance ShATermConvertible () where
    toShATermAux att _ = return $ addATerm (ShAAppl "U" [] []) att
    fromShATermAux ix att0 = case getShATerm ix att0 of
            ShAAppl "U" [] _ -> (att0, ())
            u -> fromShATermError "()" u
_______________________________________________
Glasgow-haskell-bugs mailing list
Glasgow-haskell-bugs@xxxxxxxxxxx
http://www.haskell.org/mailman/listinfo/glasgow-haskell-bugs