%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgTailCall.lhs,v 1.30 2001/06/25 14:36:04 simonpj Exp $
+% $Id: CgTailCall.lhs,v 1.31 2001/10/25 05:07:32 sof Exp $
%
%********************************************************
%* *
import Type ( isUnLiftedType )
import TyCon ( TyCon )
import PrimOp ( PrimOp )
-import Util ( zipWithEqual )
+import Util ( zipWithEqual, splitAtList )
import ListSetOps ( assocMaybe )
import Outputable
import Panic ( panic, assertPanic )
= getEndOfBlockInfo `thenFC` \ eob@(EndOfBlockInfo args_sp sequel) ->
let
- (reg_arg_amodes, stk_arg_amodes) = splitAt (length arg_regs) arg_amodes
+ (reg_arg_amodes, stk_arg_amodes) = splitAtList arg_regs arg_amodes
-- We get some stk_arg_amodes if (a) no regs, or
-- (b) args beyond arity
isFunTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
import Type ( Type, repType, splitRepFunTys )
-import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
+import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem,
+ isSingleton, lengthIs )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
import PrimRep ( isFollowableRep )
isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
in is_con_call && isUnboxedTupleCon con
&& ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l)))
- || (isSingleton args_r_to_l) )
+ || (isSingleton args_r_to_l)
)
= --trace (if isSingleton args_r_to_l
-- then "schemeT: unboxed singleton"
import Constants ( mIN_SIZE_NonUpdHeapObject )
import ClosureInfo ( mkVirtHeapOffsets )
import FastString ( FastString(..) )
+import Util ( lengthIs, listLengthCmp )
import Foreign ( Storable(..), Word8, Word16, Word32, Word64, Ptr(..),
malloc, castPtr, plusPtr, Addr )
mkITbl tc
| not (isDataTyCon tc)
= return emptyFM
- | n == length dcs -- paranoia; this is an assertion.
+ | dcs `lengthIs` n -- paranoia; this is an assertion.
= make_constr_itbls dcs
where
dcs = tyConDataCons tc
-- Assumes constructors are numbered from zero, not one
make_constr_itbls :: [DataCon] -> IO ItblEnv
make_constr_itbls cons
- | length cons <= 8
+ | listLengthCmp cons 8 /= GT -- <= 8 elements in the list
= do is <- mapM mk_vecret_itbl (zip cons [0..])
return (listToFM is)
| otherwise
linkFail :: String -> String -> IO a
linkFail who what
- = throwDyn (ProgramError (
- "\nDuring interactive linking, GHCi couldn't find the following symbol:\n" ++
- " " ++ what ++ "\n" ++
- "This may be due to you not asking GHCi to load extra object files,\n" ++
- "archives or DLLs needed by your current session. Restart GHCi, specifying\n" ++
- "the missing library using the -L/path/to/object/dir and -lmissinglibname\n" ++
- "flags, or simply by naming the relevant files on the GHCi command line.\n" ++
- "Alternatively, this link failure might indicate a bug in GHCi.\n" ++
- "If you suspect the latter, please send a bug report to:\n" ++
- " glasgow-haskell-bugs@haskell.org\n"
- ))
+ = throwDyn (ProgramError $
+ unlines [ ""
+ , "During interactive linking, GHCi couldn't find the following symbol:"
+ , ' ' : ' ' : what
+ , "This may be due to you not asking GHCi to load extra object files,"
+ , "archives or DLLs needed by your current session. Restart GHCi, specifying"
+ , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
+ , "flags, or simply by naming the relevant files on the GHCi command line."
+ , "Alternatively, this link failure might indicate a bug in GHCi."
+ , "If you suspect the latter, please send a bug report to:"
+ , " glasgow-haskell-bugs@haskell.org"
+ ])
-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
addDLL -- :: String -> IO (Ptr CChar)
) where
+import PrelByteArr
+import PrelPack ( packString )
+
+import Monad ( when )
+
import CTypes ( CChar )
import Foreign ( Ptr, nullPtr )
-import PrelByteArr
-import PrelPack (packString)
import Panic ( panic )
import DriverUtil ( prefixUnderscore )
-- RTS Linker Interface
-- ---------------------------------------------------------------------------
+lookupSymbol :: String -> IO (Maybe (Ptr a))
lookupSymbol str_in = do
let str = prefixUnderscore str_in
addr <- c_lookupSymbol (packString str)
then return Nothing
else return (Just addr)
+loadObj :: String -> IO ()
loadObj str = do
r <- c_loadObj (packString str)
- if (r == 0)
- then panic "loadObj: failed"
- else return ()
+ when (r == 0) (panic "loadObj: failed")
+unloadObj :: String -> IO ()
unloadObj str = do
r <- c_unloadObj (packString str)
- if (r == 0)
- then panic "unloadObj: failed"
- else return ()
+ when (r == 0) (panic "unloadObj: failed")
+resolveObjs :: IO Bool
resolveObjs = do
r <- c_resolveObjs
return (r /= 0) -- returns True <=> success
+addDLL :: String -> String -> IO (Ptr CChar)
addDLL path lib = do
maybe_errmsg <- c_addDLL (packString path) (packString lib)
return maybe_errmsg
+
+foreign import "initLinker" unsafe
+ initLinker :: IO ()
+
+-- ---------------------------------------------------------------------------
+-- Foreign declaractions to RTS entry points which does the real work;
+-- ---------------------------------------------------------------------------
+
type PackedString = ByteArray Int
foreign import "lookupSymbol" unsafe
foreign import "resolveObjs" unsafe
c_resolveObjs :: IO Int
-foreign import "initLinker" unsafe
- initLinker :: IO ()
-
foreign import "addDLL" unsafe
c_addDLL :: PackedString -> PackedString -> IO (Ptr CChar)
\end{code}
import SrcLoc ( noSrcLoc )
import Outputable
import Module ( ModuleName )
-import Util ( sortLt )
+import Util ( sortLt, dropList )
import ErrUtils ( dumpIfSet_dyn )
import Monad ( when )
where
(tyvars1, _, ex_tyvars, ex_theta, arg_tys, tycon1) = dataConSig data_con
field_labels = dataConFieldLabels data_con
- strict_marks = drop (length ex_theta) (dataConStrictMarks data_con)
+ strict_marks = dropList ex_theta (dataConStrictMarks data_con)
-- The 'drop' is because dataConStrictMarks
-- includes the existential dictionaries
details | null field_labels
projects / ghc-hetmet.git / commitdiff