import Outputable
import Name ( Name, getName, mkSysLocalName )
-import Id ( Id, idType, isDataConId_maybe, mkVanillaId )
+import Id ( Id, idType, isDataConId_maybe, mkVanillaId,
+ isPrimOpId_maybe )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
import FiniteMap ( FiniteMap, addListToFM, listToFM,
import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) )
+import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
import Type ( typePrimRep )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId )
import List ( intersperse, sortBy )
import Foreign ( Ptr(..), mallocBytes )
-import Addr ( addrToInt, writeCharOffAddr )
+import Addr ( Addr(..), addrToInt, writeCharOffAddr )
import CTypes ( CInt )
import PrelBase ( Int(..) )
-import PrelAddr ( Addr(..) )
import PrelGHC ( ByteArray# )
import IOExts ( unsafePerformIO )
import PrelIOBase ( IO(..) )
-- ToDo: don't build thunks for things with no free variables
buildThunk dd ([], size, id, off)
- = PUSH_G (getName id)
+ = PUSH_G (Left (getName id))
`consOL` unitOL (MKAP (off+size-1) size)
buildThunk dd ((fv:fvs), size, id, off)
= case pushAtom True dd p' (AnnVar fv) of
-- Handle case 1
| is_con_call && null args_r_to_l
- = (PUSH_G (getName con) `consOL` mkSLIDE 1 (d-s))
+ = (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
`snocOL` ENTER
-- Cases 2 and 3
-- 6 stack has valid words 0 .. 5.
pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
-pushAtom tagged d p (AnnVar v)
+pushAtom tagged d p (AnnVar v)
+ | Just primop <- isPrimOpId_maybe v
+ = case primop of
+ CCallOp _ -> panic "pushAtom: byte code generator can't handle CCalls"
+ other -> (unitOL (PUSH_G (Right primop)), 1)
+
+ | otherwise
= let str = "\npushAtom " ++ showSDocDebug (ppr v)
++ " :: " ++ showSDocDebug (pprType (idType v))
++ ", depth = " ++ show d
result
= case lookupBCEnv_maybe p v of
Just d_v -> (toOL (nOfThem nwords (PUSH_L (d-d_v+sz_t-2))), nwords)
- Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G nm), nwords)
+ Nothing -> ASSERT(sz_t == 1) (unitOL (PUSH_G (Left nm)), nwords)
nm = case isDataConId_maybe v of
Just c -> getName c
let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+
in unsafePerformIO (
- do a@(Ptr addr) <- mallocBytes (n+1)
- strncpy a ba (fromIntegral n)
- writeCharOffAddr addr n '\0'
- return addr
+ do (Ptr a#) <- mallocBytes (n+1)
+ strncpy (Ptr a#) ba (fromIntegral n)
+ writeCharOffAddr (A# a#) n '\0'
+ return (A# a#)
)
_ -> panic "StgInterp.lit2expr: unhandled string constant type"
import PrimRep ( PrimRep )
import DataCon ( DataCon )
import VarSet ( VarSet )
+import PrimOp ( PrimOp )
\end{code}
| PUSH_LL Int Int{-2 offsets-}
| PUSH_LLL Int Int Int{-3 offsets-}
-- Push a ptr
- | PUSH_G Name
+ | PUSH_G (Either Name PrimOp)
-- Push an alt continuation
| PUSH_AS Name PrimRep -- push alts and BCO_ptr_ret_info
-- PrimRep so we know which itbl
ppr (PUSH_L offset) = text "PUSH_L " <+> int offset
ppr (PUSH_LL o1 o2) = text "PUSH_LL " <+> int o1 <+> int o2
ppr (PUSH_LLL o1 o2 o3) = text "PUSH_LLL" <+> int o1 <+> int o2 <+> int o3
- ppr (PUSH_G nm) = text "PUSH_G " <+> ppr nm
+ ppr (PUSH_G (Left nm)) = text "PUSH_G " <+> ppr nm
+ ppr (PUSH_G (Right op)) = text "PUSH_G " <+> text "PrelPrimopWrappers."
+ <> ppr op
ppr (PUSH_AS nm pk) = text "PUSH_AS " <+> ppr nm <+> ppr pk
ppr (PUSH_UBX lit nw) = text "PUSH_UBX" <+> parens (int nw) <+> ppr lit
ppr (PUSH_TAG n) = text "PUSH_TAG" <+> int n
\section[ByteCodeItbls]{Generate infotables for interpreter-made bytecodes}
\begin{code}
-module ByteCodeItbls ( ItblEnv, mkITbls ) where
+module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where
#include "HsVersions.h"
import FastString ( FastString(..) )
import Foreign ( Storable(..), Word8, Word16, Word32, Ptr(..),
- malloc, castPtr, plusPtr )
+ malloc, castPtr, plusPtr, Addr )
import Addr ( addrToInt )
import Bits ( Bits(..), shiftR )
import PrelBase ( Int(..) )
-import PrelAddr ( Addr(..) )
import PrelIOBase ( IO(..) )
\end{code}
\begin{code}
-type ItblEnv = FiniteMap Name (Ptr StgInfoTable)
-
-#if __GLASGOW_HASKELL__ <= 408
-type ItblPtr = Addr
-#else
type ItblPtr = Ptr StgInfoTable
-#endif
+type ItblEnv = FiniteMap Name ItblPtr
+
-- Make info tables for the data decls in this module
mkITbls :: [TyCon] -> IO ItblEnv
import Outputable
import Name ( Name, getName, nameModule, toRdrName )
import RdrName ( rdrNameOcc, rdrNameModule )
-import OccName ( occNameString )
+import OccName ( occNameString, occNameUserString )
import FiniteMap ( FiniteMap, addListToFM, filterFM,
addToFM, lookupFM, emptyFM )
import CoreSyn
import Literal ( Literal(..) )
+import PrimOp ( PrimOp, primOpOcc )
import PrimRep ( PrimRep(..) )
import Util ( global )
import Constants ( wORD_SIZE )
import Linker ( lookupSymbol )
import FastString ( FastString(..) )
import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) )
-import ByteCodeItbls ( ItblEnv )
+import ByteCodeItbls ( ItblEnv, ItblPtr )
import Monad ( foldM )
newIntArray, writeIntArray,
newAddrArray, writeAddrArray )
import Foreign ( Word16, Ptr(..) )
-import Addr ( Word )
+import Addr ( Word, Addr )
import PrelBase ( Int(..) )
-import PrelAddr ( Addr(..) )
import PrelGHC ( BCO#, newBCO#, unsafeCoerce#,
ByteArray#, Array#, addrToHValue#, mkApUpd0# )
import IOExts ( IORef, fixIO, readIORef, writeIORef )
data UnlinkedBCO
= UnlinkedBCO Name
- (SizedSeq Word16) -- insns
- (SizedSeq Word) -- literals
- (SizedSeq Name) -- ptrs
- (SizedSeq Name) -- itbl refs
+ (SizedSeq Word16) -- insns
+ (SizedSeq Word) -- literals
+ (SizedSeq (Either Name PrimOp)) -- ptrs
+ (SizedSeq Name) -- itbl refs
nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm
do -- pass 2: generate the instruction, ptr and nonptr bits
insns <- return emptySS :: IO (SizedSeq Word16)
lits <- return emptySS :: IO (SizedSeq Word)
- ptrs <- return emptySS :: IO (SizedSeq Name)
+ ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp))
itbls <- return emptySS :: IO (SizedSeq Name)
let init_asm_state = (insns,lits,ptrs,itbls)
(final_insns, final_lits, final_ptrs, final_itbls)
return (UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls)
-- instrs nonptrs ptrs itbls
-type AsmState = (SizedSeq Word16, SizedSeq Word, SizedSeq Name, SizedSeq Name)
+type AsmState = (SizedSeq Word16, SizedSeq Word,
+ SizedSeq (Either Name PrimOp), SizedSeq Name)
data SizedSeq a = SizedSeq !Int [a]
emptySS = SizedSeq 0 []
PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3
PUSH_G nm -> do (p, st2) <- ptr st nm
instr2 st2 i_PUSH_G p
- PUSH_AS nm pk -> do (p, st2) <- ptr st nm
+ PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm)
(np, st3) <- ctoi_itbl st2 pk
instr3 st3 i_PUSH_AS p np
PUSH_UBX lit nws -> do (np, st2) <- literal st lit
= addr st ret_itbl_addr
where
ret_itbl_addr = case pk of
- PtrRep -> stg_ctoi_ret_R1_info
- IntRep -> stg_ctoi_ret_R1_info
- CharRep -> stg_ctoi_ret_R1_info
+ PtrRep -> stg_ctoi_ret_R1p_info
+ IntRep -> stg_ctoi_ret_R1n_info
+ CharRep -> stg_ctoi_ret_R1n_info
FloatRep -> stg_ctoi_ret_F1_info
DoubleRep -> stg_ctoi_ret_D1_info
_ -> pprPanic "mkBits.ctoi_itbl" (ppr pk)
FloatRep -> stg_gc_f1_info
DoubleRep -> stg_gc_d1_info
-foreign label "stg_ctoi_ret_R1_info" stg_ctoi_ret_R1_info :: Addr
-foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
-foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
+foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Addr
+foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Addr
+foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Addr
+foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Addr
foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Addr
foreign label "stg_gc_f1_info" stg_gc_f1_info :: Addr
ptrs_parr = case ptrs_arr of Array lo hi parr -> parr
itbls_arr = array (0, n_itbls-1) (indexify linked_itbls)
- :: UArray Int Addr
+ :: UArray Int ItblPtr
itbls_barr = case itbls_arr of UArray lo hi barr -> barr
insns_arr | n_insns > 65535
BCO bco# <- newBCO insns_barr literals_barr ptrs_parr itbls_barr
- return (unsafeCoerce# bco#)
- --case mkApUpd0# (unsafeCoerce# bco#) of
- -- (# final_bco #) -> return final_bco
+ -- WAS: return (unsafeCoerce# bco#)
+ case mkApUpd0# (unsafeCoerce# bco#) of
+ (# final_bco #) -> return final_bco
data BCO = BCO BCO#
= IO (\s -> case newBCO# a b c d s of (# s1, bco #) -> (# s1, BCO bco #))
-lookupCE :: ClosureEnv -> Name -> IO HValue
-lookupCE ce nm
+lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue
+lookupCE ce (Right primop)
+ = do m <- lookupSymbol (primopToCLabel primop "closure")
+ case m of
+ Just (Ptr addr) -> case addrToHValue# addr of
+ (# hval #) -> do addCAF hval
+ return hval
+ Nothing -> pprPanic "ByteCodeGen.lookupCE(primop)" (ppr primop)
+lookupCE ce (Left nm)
= case lookupFM ce nm of
Just aa -> return aa
Nothing
-> do m <- lookupSymbol (nameToCLabel nm "closure")
case m of
- Just (A# addr) -> case addrToHValue# addr of
- (# hval #) -> do addCAF hval
- return hval
+ Just (Ptr addr) -> case addrToHValue# addr of
+ (# hval #) -> do addCAF hval
+ return hval
Nothing -> pprPanic "ByteCodeGen.lookupCE" (ppr nm)
-lookupIE :: ItblEnv -> Name -> IO Addr
+lookupIE :: ItblEnv -> Name -> IO (Ptr a)
lookupIE ie con_nm
= case lookupFM ie con_nm of
- Just (Ptr a) -> return a
+ Just (Ptr a) -> return (Ptr a)
Nothing
-> do -- try looking up in the object files.
m <- lookupSymbol (nameToCLabel con_nm "con_info")
Just addr -> return addr
Nothing -> pprPanic "ByteCodeGen.lookupIE" (ppr con_nm)
--- HACK!!! ToDo: cleaner
+-- HACKS!!! ToDo: cleaner
nameToCLabel :: Name -> String{-suffix-} -> String
nameToCLabel n suffix
= _UNPK_(moduleNameFS (rdrNameModule rn))
++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix
where rn = toRdrName n
+primopToCLabel :: PrimOp -> String{-suffix-} -> String
+primopToCLabel primop suffix
+ = let str = "PrelPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix
+ in trace ("primopToCLabel: " ++ str)
+ str
+
\end{code}
%************************************************************************
module Linker (
loadObj, -- :: String -> IO ()
unloadObj, -- :: String -> IO ()
- lookupSymbol, -- :: String -> IO (Maybe Addr)
+ lookupSymbol, -- :: String -> IO (Maybe (Ptr a))
resolveObjs, -- :: IO ()
) where
-import Addr
+import Foreign ( Ptr, nullPtr )
import PrelByteArr
import PrelPack (packString)
import Panic ( panic )
lookupSymbol str = do
addr <- c_lookupSymbol (packString str)
- if addr == nullAddr
+ if addr == nullPtr
then return Nothing
else return (Just addr)
type PackedString = ByteArray Int
foreign import "lookupSymbol" unsafe
- c_lookupSymbol :: PackedString -> IO Addr
+ c_lookupSymbol :: PackedString -> IO (Ptr a)
foreign import "loadObj" unsafe
c_loadObj :: PackedString -> IO Int
\begin{code}
-- NB: ordering of clauses somewhere driven by
-- the desire to getting sane patt-matching behavior
+
primCode [res] IntegerCmpOp args@[sa1,da1, sa2,da2]
= gmpCompare res (sa1,da1, sa2,da2)
stringToStringBuffer :: String -> IO StringBuffer
stringToStringBuffer str =
do let sz@(I# sz#) = length str + 1
- (Ptr a@(A# a#)) <- mallocBytes sz
- fill_in str a
- writeCharOffAddr a (sz-1) '\0' -- sentinel
+ (Ptr a#) <- mallocBytes sz
+ fill_in str (A# a#)
+ writeCharOffAddr (A# a#) (sz-1) '\0' -- sentinel
return (StringBuffer a# sz# 0# 0#)
where
fill_in [] _ = return ()
fill_in cs (a `plusAddr` 1)
freeStringBuffer :: StringBuffer -> IO ()
-freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr (A# a#))
+freeStringBuffer (StringBuffer a# _ _ _) = Foreign.free (Ptr a#)
#endif
\end{code}
#-----------------------------------------------------------------------------
# Rules
+PrelPrimopWrappers.hs: ../../compiler/prelude/primops.txt
+ rm -f PrelPrimopWrappers.hs
+ ../../utils/genprimopcode/genprimopcode --make-haskell-wrappers \
+ < ../../compiler/prelude/primops.txt > PrelPrimopWrappers.hs
+
PrelGHC.$(way_)hi : PrelGHC.hi-boot
cp $< $@
-boot :: PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
+boot :: PrelPrimopWrappers.hs PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
+all :: PrelPrimopWrappers.hs
DLL_DESCRIPTION="GHC-compiled Haskell Prelude"
all :: PrelMain.dll_o
endif
-CLEAN_FILES += PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
+CLEAN_FILES += PrelPrimopWrappers.hs PrelGHC.hi $(foreach way, $(WAYS), PrelGHC.$(way)_hi)
#
# If we're building the unregisterised way, it may well be for Hugs.
"--primop-list"
-> putStr (gen_primop_list p_o_specs)
- "--c-bytecode-enum"
- -> putStr (gen_enum_decl p_o_specs)
+ "--make-haskell-wrappers"
+ -> putStr (gen_wrappers p_o_specs)
)
"--primop-primop-info",
"--primop-tag",
"--primop-list",
-
- "--c-bytecode-enum"
+ "--make-haskell-wrappers"
]
------------------------------------------------------------------
-- Code generators -----------------------------------------------
------------------------------------------------------------------
+gen_wrappers (Info defaults pos)
+ = "module PrelPrimopWrappers where\n"
+ ++ "import qualified PrelGHC\n"
+ ++ unlines (map f (filter (not.dodgy) pos))
+ where
+ f spec = let args = map (\n -> "a" ++ show n) [1 .. arity (ty spec)]
+ src_name = wrap (name spec)
+ in "{-# NOINLINE " ++ src_name ++ " #-}\n" ++
+ src_name ++ " " ++ unwords args
+ ++ " = (PrelGHC." ++ name spec ++ ") " ++ unwords args
+ wrap nm | isLower (head nm) = nm
+ | otherwise = "(" ++ nm ++ ")"
+
+ dodgy spec
+ = name spec `elem`
+ [-- C code generator can't handle these
+ "seq#",
+ "tagToEnum#",
+ -- not interested in parallel support
+ "par#", "parGlobal#", "parLocal#", "parAt#",
+ "parAtAbs#", "parAtRel#", "parAtForNow#"
+ ]
+
+
gen_primop_list (Info defaults pos)
= unlines (
[ " [" ++ cons (head pos) ]
f i n = "tagOf_PrimOp " ++ cons i
++ " = _ILIT(" ++ show n ++ ") :: FastInt"
-gen_enum_decl (Info defaults pos)
- = let conss = map cons pos
- in "enum PrimOp {\n " ++ head conss ++ "\n"
- ++ unlines (map (" , "++) (tail conss)) ++ "};\n"
-
gen_data_decl (Info defaults pos)
= let conss = map cons pos
in "data PrimOp\n = " ++ head conss ++ "\n"
tvsIn (TyVar tv) = [tv]
tvsIn (TyUTup tys) = concatMap tvsIn tys
+arity = length . fst . flatTys
+
------------------------------------------------------------------
-- Abstract syntax -----------------------------------------------
projects / ghc-hetmet.git / commitdiff