ghc stackfaults

[John Meacham]

ghc 6.6 and 6.6.1 both go into infinite loops and eventually die with a
stackfault when trying to compile the attached file with optimizations
turned on.

-- 
John Meacham - ⑆repetae.net⑆john⑈
-------------- next part --------------
module C.Op where

{-

Basic operations. These are chosen to be roughly equivalent to c-- operations,
but can be effectively used to generate C or assembly code as well.

An operation consists of the operation itself, the type of the arguments and
return value, and a hint attached to each argument.

A condition is that the operation must be fully determined by the operation
name and the type of its arguments. this specifically does not include the
hint. For instance, since whether a number is signed or unsigned is in the
hint, so the operation itself must say whether it is signed or unsigned.

Also, distinct algorithms should be given different operations, for instance
floating point and integer comparison are so different that they should be
separate opcodes, even if it could be determined by the type they operate on.

-}



-- these take 2 arguments of the same type, and return one of the same type.
-- an exception are the mulx routines, which may return a type exactly
-- double in size of the original, and the shift and rotate routines, where the
-- second argument may be of any width and is interpreted as an unsigned
-- number.
--
-- the invarient is that the return type is always exactly determined by the
-- argument types


data BinOp
    = Add
    | Sub

    | Mul
    | Mulx
    | UMulx

    | Div   -- ^ round to -Infinity
    | Mod   -- ^ mod rounding to -Infinity

    | Quot  -- ^ round to 0
    | Rem   -- ^ rem rounding to 0

    | UDiv  -- ^ round to zero (unsigned)
    | Modu  -- ^ unsigned mod

    -- bitwise
    | And
    | Or
    | Xor
    | Not
    | Shl
    | Shr    -- ^ shift right logical
    | Shra   -- ^ shift right arithmetic
    | Rotl
    | Rotr
    -- floating
    | FAdd
    | FSub
    | FDiv
    | FMul
    | FPwr
    | FAtan2

    -- These all compare two things of the same type, and return a boolean.
    | Eq
    | NEq
    | Gt
    | Gte
    | Lt
    | Lte
    -- unsigned versions
    | UGt
    | UGte
    | ULt
    | ULte

    -- floating point comparasons
    | FEq
    | FNEq
    | FGt
    | FGte
    | FLt
    | FLte
    -- whether two values can be compared at all.
    | FOrdered
    deriving(Eq,Show,Ord)

data UnOp
    = Neg   -- ^ 2s compliment negation
    | Com   -- ^ bitwise compliment
    -- floating
    | FAbs  -- ^ floating absolute value
    | Sin
    | Cos
    | Tan
    | Sinh
    | Cosh
    | Tanh
    | Asin
    | Acos
    | Atan
    | Log
    | Exp
    | Sqrt
    deriving(Eq,Show,Ord)


-- conversion ops always are NOPs and can be omitted when
-- the initial and target types are the same when the hint is ignored.

data ConvOp
    = F2I
    | F2U
    | U2F
    | I2F
    | Lobits
    | Sx
    | Zx
    -- these should only be used when the
    -- size of the concrete types is not
    -- known. so you don't know whether
    -- to extend or shrink the value
    | I2I
    | U2U
    deriving(Eq,Show,Ord)


data ValOp
    = NaN
    | PInf
    | NInf
    | PZero
    | NZero
    deriving(Eq,Show,Ord)

-- A term, can have values
newtype T v = V (T v)
    deriving(Eq,Show,Ord)

data V v 
    = ValOp ValOp Ty
    | ConvOp ConvOp Ty v
    | BinOp BinOp v v
    | UnOp  UnOp v
    deriving(Eq,Show,Ord)

data TyBits = Bits !Int | BitsPtr | BitsExt String
    deriving(Eq,Show,Ord)
data TyHint = HintSigned | HintUnsigned | HintFloat
    deriving(Eq,Show,Ord)

data Ty
    = TyBits !TyBits !TyHint
    | TyBool
    deriving(Eq,Show,Ord)

{-
class OpValue v where
    opCompare :: v -> v -> Maybe Ordering
    opToInteger :: v -> Maybe Integer
    opFromInteger :: v -> Integer -> v


optimize :: OpValue v => T v -> Writer Int (T v)
optimize v = f v where
    f (ConvOp _ t v) = do
        fv <- f v
        if getType fv == t then tell 1 >> fv else return fv
    f v   = return v
    -}


{-
instance CanType (T v) Ty where
    getType (ValOp _ t) = t
    getType (Val t _) = t
    getType (ConvOp _ t _) = t
    getType (UnOp _ v) = getType v
    getType (BinOp b v1 v2) = binopType b (getType v1) (getType v2)
-}

binopType :: BinOp -> Ty -> Ty -> Ty
binopType Mulx  (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h
binopType UMulx (TyBits (Bits i) h) _ = TyBits (Bits (i*2)) h
binopType Eq  _ _ =  TyBool
binopType NEq _ _ =  TyBool
binopType Gt  _ _ =  TyBool
binopType Gte _ _ =  TyBool
binopType Lt  _ _ =  TyBool
binopType Lte _ _ =  TyBool
binopType UGt  _ _ =  TyBool
binopType UGte _ _ =  TyBool
binopType ULt  _ _ =  TyBool
binopType ULte _ _ =  TyBool
binopType FEq  _ _ =  TyBool
binopType FNEq _ _ =  TyBool
binopType FGt  _ _ =  TyBool
binopType FGte _ _ =  TyBool
binopType FLt  _ _ =  TyBool
binopType FLte _ _ =  TyBool
binopType FOrdered _ _ =  TyBool
binopType _ t1 _ = t1

isCommutable :: BinOp -> Bool
isCommutable x = f x where
    f Add = True
    f Mul = True
    f And = True
    f Or  = True
    f Xor = True
    f Eq  = True
    f NEq = True
    f FAdd = True
    f FMul = True
    f _ = False

isAssociative :: BinOp -> Bool
isAssociative x = f x where
    f Add = True
    f Mul = True
    f And = True
    f Or  = True
    f Xor = True
    f _ = False

binopInfix :: BinOp -> Maybe (String,Int)
binopInfix UDiv = Just ("/",8)
binopInfix Mul  = Just ("*",8)
binopInfix Modu = Just ("%",8)
binopInfix Sub  = Just ("-",7)
binopInfix Add  = Just ("+",7)
binopInfix Shr  = Just (">>",6)
binopInfix Shl  = Just ("<<",6)
binopInfix And  = Just ("&",5)
binopInfix Xor  = Just ("^",4)
binopInfix Or   = Just ("|",3)
binopInfix UGte = Just (">=",2)
binopInfix UGt  = Just (">",2)
binopInfix ULte = Just ("<=",2)
binopInfix ULt  = Just ("<",2)
binopInfix Eq   = Just ("==",2)
binopInfix NEq  = Just ("!=",2)
binopInfix _ = Nothing