Unknown opcode 10904

I got this error working with ghci just now. Contrary to what it says, I'm not on linux but on Mac OS X 10.4.11 (intel).

    *Main> quickCheck prop_typecheck
    <interactive>: internal error: interpretBCO: unknown or unimplemented opcode     10904
        (GHC version 6.6 for i386_unknown_linux)
        Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug

The text of the program follows.

import Foreign (unsafePerformIO)
import List (nub)
import System.Random (mkStdGen)
import Test.QuickCheck

data Term = Const | Var Int | Abs Term | Appl Term Term
            deriving (Show)
data Type = Base | Type :->: Type
            deriving (Eq, Show)

data TypeScheme = T Type | V Int | Arr TypeScheme TypeScheme
                  deriving (Eq, Show)

eval env Const = Const
eval env (Var x) | x < length env = env !! x
eval env (Abs n) = Abs n
eval env (Appl m n) = case eval env m of
                        Abs m' -> eval env' m'
                            where env' = eval env n : env
                        _ -> error "non-functional application"

data Fresh a = Fr(Int -> (Int, a))

instance Monad Fresh where
     return x = Fr(\ctr -> (ctr, x))
     (Fr m) >>= f = Fr(\x -> let (ctr, x') = m x in 
                             let Fr f' = f x' in
                             f' ctr)

fresh :: Fresh Int
fresh = Fr(\ctr -> (ctr+1, ctr))

runFresh (Fr f) = snd $ f 0

arrowTy (s :->: t) = True
arrowTy _ = False

unify (T s) (T t) | s == t = Just[]
unify (V x) t = Just [(x, t)]
unify s (V y) = Just [(y, s)]
unify (Arr s1 t1) (Arr s2 t2) = 
    do subst1 <- unify s1 s2
       subst2 <- unify t1 t2
       Just (List.nub $ subst1 ++ subst2)

applySubst :: (Int, TypeScheme) -> TypeScheme -> TypeScheme
applySubst (x, xIm) (T ty) = T ty
applySubst (x, xIm) (V y) | x == y = xIm
                          | otherwise = V y
applySubst (x, xIm) (Arr s t) = Arr (applySubst (x, xIm) s)
                                    (applySubst (x, xIm) t)

applySubsts :: [(Int, TypeScheme)] -> TypeScheme -> TypeScheme
applySubsts substs ty = foldr (applySubst) ty substs

typeCheck :: [TypeScheme] -> Term -> Fresh TypeScheme
typeCheck env Const = return $ T Base
typeCheck env (Var x) | x < length env = return (env !! x)
typeCheck env (Abs n) = 
    do xTy <- fresh
       nTy <- typeCheck (V xTy : env) n
       return (Arr (V xTy) nTy)
typeCheck env (Appl m n) =
    do mTy <- typeCheck env m
       nTy <- typeCheck env n
       case mTy of
        Arr mArgTy mResTy -> 
            case unify mArgTy nTy of
              Nothing -> error "unification failed"
              Just substn ->
                  return (applySubsts substn mResTy)
        _ ->  error "ill-typed application"

typeGen :: Int -> Gen Type
typeGen size = oneof $
    [return Base] ++
    if size <= 0 then [] else
        [do s <- typeGen (size-1)
            t <- typeGen (size-1)
            return $ s :->: t ]

asList Nothing = []
asList (Just x) = [x]

oneofMaybe :: [Gen(Maybe a)] -> Gen (Maybe a)
oneofMaybe [] = return Nothing
oneofMaybe (x:xs) = do x' <- x
                       xs' <- oneofMaybe xs
                       case (x', xs') of
                         (Nothing, Nothing) -> return Nothing
                         _ -> oneof (map (return . Just) $ 
                                         asList x' ++ asList xs')

typedTermGen :: [Type] -> Type -> Int -> Gen (Maybe Term)
typedTermGen ctxt tau size = oneofMaybe (
    (case tau of
      Base -> [return $ Just Const]
      tau :->: tau' -> 
          if size <= 0 then [] else
          [do n <- typedTermGen (tau:ctxt) tau' decSize
              return $ do n' <- n
                          Just(Abs n')]
    ) ++
    (if size <= 0 then [] else
    [do sigma <- typeGen decSize
--        let sigma = (unsafePerformIO $ putStr $ show sigma') `seq` sigma'
        m <- typedTermGen ctxt (sigma :->: tau) decSize
        n <- typedTermGen ctxt (sigma) decSize
        return $ do m' <- m ; n' <- n; Just (Appl m' n')
    ]) ++
    [return$ Just (Var x) | (x, xType) <- zip [0..] ctxt, xType == tau]
    )
        where decSize = size-1

-- graph a function over certain inputs
graph f xs = [(x, f x) | x <- xs]

make n g size = [generate size (System.Random.mkStdGen i) g | i<-[0..n]]

prop_typecheck = forAll (sized (typedTermGen [] Base)) (\m ->
                    let m' = Maybe.fromJust m in
                    (runFresh (typeCheck [] m')) == Some (T Base))

Trac metadata

Trac field	Value
Version	6.6
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	Compiler
Test case
Differential revisions
BlockedBy
Related
Blocking
CC
Operating system	MacOS X
Architecture