#include "HsVersions.h"
import Outputable
-import Name ( Name, getName, mkSysLocalName )
-import Id ( Id, idType, isDataConId_maybe, mkVanillaId,
- isPrimOpId_maybe, idPrimRep )
+import Name ( Name, getName )
+import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId,
+ idPrimRep, mkSysLocal, idName, isFCallId_maybe, isPrimOpId )
+import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
import OrdList ( OrdList, consOL, snocOL, appOL, unitOL,
nilOL, toOL, concatOL, fromOL )
-import FiniteMap ( FiniteMap, addListToFM, listToFM,
- addToFM, lookupFM, fmToList, plusFM )
+import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM,
+ addToFM, lookupFM, fmToList )
import CoreSyn
import PprCore ( pprCoreExpr )
import Literal ( Literal(..), literalPrimRep )
import PrimRep ( PrimRep(..) )
-import PrimOp ( PrimOp(..) )
+import PrimOp ( PrimOp(..) )
import CoreFVs ( freeVars )
-import Type ( typePrimRep )
+import Type ( typePrimRep, splitTyConApp_maybe, isTyVarTy )
import DataCon ( dataConTag, fIRST_TAG, dataConTyCon,
dataConWrapId, isUnboxedTupleCon )
-import TyCon ( TyCon, tyConFamilySize )
+import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons,
+ isFunTyCon, isUnboxedTupleTyCon )
import Class ( Class, classTyCon )
-import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem )
+import Type ( Type, repType, splitRepFunTys )
+import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem,
+ isSingleton, lengthIs )
+import DataCon ( dataConRepArity )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
-import PrimRep ( getPrimRepSize, isFollowableRep )
+import PrimRep ( isFollowableRep )
import CmdLineOpts ( DynFlags, DynFlag(..) )
import ErrUtils ( showPass, dumpIfSet_dyn )
import Unique ( mkPseudoUnique3 )
import FastString ( FastString(..) )
import Panic ( GhcException(..) )
import PprType ( pprType )
+import SMRep ( arrWordsHdrSize, arrPtrsHdrSize )
+import Constants ( wORD_SIZE )
import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse )
import ByteCodeItbls ( ItblEnv, mkITbls )
import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO,
- ClosureEnv, HValue, filterNameMap,
+ ClosureEnv, HValue, filterNameMap, linkFail,
iNTERP_STACK_CHECK_THRESH )
+import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 )
+import Linker ( lookupSymbol )
-import List ( intersperse, sortBy )
-import Foreign ( Ptr(..), mallocBytes )
-import Addr ( Addr(..), addrToInt, writeCharOffAddr )
+import List ( intersperse, sortBy, zip4 )
+import Foreign ( Ptr(..), castPtr, mallocBytes, pokeByteOff, Word8 )
import CTypes ( CInt )
import Exception ( throwDyn )
-import PrelBase ( Int(..) )
-import PrelGHC ( ByteArray# )
-import IOExts ( unsafePerformIO )
-import PrelIOBase ( IO(..) )
+import GlaExts ( Int(..), ByteArray# )
+import Monad ( when )
+import Maybe ( isJust )
+import Char ( ord )
\end{code}
%************************************************************************
let flatBinds = concatMap getBind binds
getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)]
getBind (Rec binds) = [(bndr, freeVars rhs) | (bndr,rhs) <- binds]
- final_state = runBc (BcM_State [] 0)
- (mapBc (schemeR True) flatBinds
- `thenBc_` returnBc ())
- (BcM_State proto_bcos final_ctr) = final_state
+
+ (BcM_State proto_bcos final_ctr mallocd, ())
+ <- runBc (BcM_State [] 0 [])
+ (mapBc (schemeR True []) flatBinds `thenBc_` returnBc ())
+ -- ^^
+ -- better be no free vars in these top-level bindings
+
+ when (not (null mallocd))
+ (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
(panic "invented_id's type")
let invented_name = idName invented_id
- let (BcM_State all_proto_bcos final_ctr)
- = runBc (BcM_State [] 0)
- (schemeR True (invented_id, freeVars expr))
+ annexpr = freeVars expr
+ fvs = filter (not.isTyVar) (varSetElems (fst annexpr))
+
+ (BcM_State all_proto_bcos final_ctr mallocd, ())
+ <- runBc (BcM_State [] 0 [])
+ (schemeR True fvs (invented_id, annexpr))
+
+ when (not (null mallocd))
+ (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
+
dumpIfSet_dyn dflags Opt_D_dump_BCOs
"Proto-bcos" (vcat (intersperse (char ' ') (map ppr all_proto_bcos)))
-- Create a BCO and do a spot of peephole optimisation on the insns
-- at the same time.
-mkProtoBCO nm instrs_ordlist origin
- = ProtoBCO nm maybe_with_stack_check origin
+mkProtoBCO nm instrs_ordlist origin mallocd_blocks
+ = ProtoBCO nm maybe_with_stack_check origin mallocd_blocks
where
-- Overestimate the stack usage (in words) of this BCO,
-- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit
-- variable to which this value was bound, so as to give the
-- resulting BCO a name. Bool indicates top-levelness.
-schemeR :: Bool -> (Id, AnnExpr Id VarSet) -> BcM ()
-schemeR is_top (nm, rhs)
+schemeR :: Bool -> [Id] -> (Id, AnnExpr Id VarSet) -> BcM ()
+schemeR is_top fvs (nm, rhs)
{-
| trace (showSDoc (
(char ' '
= undefined
-}
| otherwise
- = schemeR_wrk is_top rhs nm (collect [] rhs)
+ = schemeR_wrk is_top fvs rhs nm (collect [] rhs)
collect xs (_, AnnNote note e)
collect xs not_lambda
= (reverse xs, not_lambda)
-schemeR_wrk is_top original_body nm (args, body)
+schemeR_wrk is_top fvs original_body nm (args, body)
| Just dcon <- maybe_toplevel_null_con_rhs
= --trace ("nullary constructor! " ++ showSDocDebug (ppr nm)) (
emitBc (mkProtoBCO (getName nm) (toOL [PACK dcon 0, ENTER])
--)
| otherwise
- = let fvs = filter (not.isTyVar) (varSetElems (fst original_body))
- all_args = reverse args ++ fvs
+ = let all_args = reverse args ++ fvs
szsw_args = map taggedIdSizeW all_args
szw_args = sum szsw_args
p_init = listToFM (zip all_args (mkStackOffsets 0 szsw_args))
where
maybe_toplevel_null_con_rhs
| is_top && null args
- = case snd body of
+ = case nukeTyArgs (snd body) of
AnnVar v_wrk
-> case isDataConId_maybe v_wrk of
Nothing -> Nothing
| otherwise
= Nothing
+ nukeTyArgs (AnnApp f (_, AnnType _)) = nukeTyArgs (snd f)
+ nukeTyArgs other = other
+
+
-- Let szsw be the sizes in words of some items pushed onto the stack,
-- which has initial depth d'. Return the values which the stack environment
-- should map these items to.
-- Delegate tail-calls to schemeT.
schemeE d s p e@(fvs, AnnApp f a)
- = returnBc (schemeT d s p (fvs, AnnApp f a))
+ = schemeT d s p (fvs, AnnApp f a)
+
schemeE d s p e@(fvs, AnnVar v)
| isFollowableRep v_rep
- = returnBc (schemeT d s p (fvs, AnnVar v))
+ = -- Ptr-ish thing; push it in the normal way
+ schemeT d s p (fvs, AnnVar v)
| otherwise
= -- returning an unboxed value. Heave it on the stack, SLIDE, and RETURN.
- let (push, szw) = pushAtom True d p (AnnVar v)
- in returnBc (push -- value onto stack
- `appOL` mkSLIDE szw (d-s) -- clear to sequel
- `snocOL` RETURN v_rep) -- go
+ pushAtom True d p (AnnVar v) `thenBc` \ (push, szw) ->
+ returnBc (push -- value onto stack
+ `appOL` mkSLIDE szw (d-s) -- clear to sequel
+ `snocOL` RETURN v_rep) -- go
where
v_rep = typePrimRep (idType v)
schemeE d s p (fvs, AnnLit literal)
- = let (push, szw) = pushAtom True d p (AnnLit literal)
- l_rep = literalPrimRep literal
+ = pushAtom True d p (AnnLit literal) `thenBc` \ (push, szw) ->
+ let l_rep = literalPrimRep literal
in returnBc (push -- value onto stack
`appOL` mkSLIDE szw (d-s) -- clear to sequel
`snocOL` RETURN l_rep) -- go
+
+{-
+ Deal specially with the cases
+ let x = fn atom1 .. atomn in B
+ and
+ let x = Con atom1 .. atomn in B
+ (Con must be saturated)
+
+ In these cases, generate code to allocate in-line.
+
+ This is optimisation of the general case for let, which follows
+ this one; this case can safely be omitted. The reduction in
+ interpreter execution time seems to be around 5% for some programs,
+ with a similar drop in allocations.
+
+ This optimisation should be done more cleanly. As-is, it is
+ inapplicable to RHSs in letrecs, and needlessly duplicates code in
+ schemeR and schemeT. Some refactoring of the machinery would cure
+ both ills.
+-}
+schemeE d s p ee@(fvs, AnnLet (AnnNonRec x rhs) b)
+ | ok_to_go
+ = let d_init = if is_con then d else d'
+ in
+ mkPushes d_init args_r_to_l_reordered `thenBc` \ (d_final, push_code) ->
+ schemeE d' s p' b `thenBc` \ body_code ->
+ let size = d_final - d_init
+ alloc = if is_con then nilOL else unitOL (ALLOC size)
+ pack = unitOL (if is_con then PACK the_dcon size else MKAP size size)
+ in
+ returnBc (alloc `appOL` push_code `appOL` pack
+ `appOL` body_code)
+ where
+ -- Decide whether we can do this or not
+ (ok_to_go, is_con, the_dcon, the_fn)
+ = case maybe_fn of
+ Nothing -> (False, bomb 1, bomb 2, bomb 3)
+ Just (Left fn) -> (True, False, bomb 5, fn)
+ Just (Right dcon)
+ | dataConRepArity dcon <= length args_r_to_l
+ -> (True, True, dcon, bomb 6)
+ | otherwise
+ -> (False, bomb 7, bomb 8, bomb 9)
+ bomb n = panic ("schemeE.is_con(hacky hack hack) " ++ show n)
+
+ -- Extract the args (R -> L) and fn
+ args_r_to_l_reordered
+ | not is_con
+ = args_r_to_l
+ | otherwise
+ = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
+ where isPtr = isFollowableRep . atomRep
+
+ args_r_to_l = filter (not.isTypeAtom.snd) args_r_to_l_raw
+ isTypeAtom (AnnType _) = True
+ isTypeAtom _ = False
+
+ (args_r_to_l_raw, maybe_fn) = chomp rhs
+ chomp expr
+ = case snd expr of
+ AnnVar v
+ | isFCallId v || isPrimOpId v
+ -> ([], Nothing)
+ | otherwise
+ -> case isDataConId_maybe v of
+ Just dcon -> ([], Just (Right dcon))
+ Nothing -> ([], Just (Left v))
+ AnnApp f a -> case chomp f of (az, f) -> (a:az, f)
+ AnnNote n e -> chomp e
+ other -> ([], Nothing)
+
+ -- This is the env in which to translate the body
+ p' = addToFM p x d
+ d' = d + 1
+
+ -- Shove the args on the stack, including the fn in the non-dcon case
+ tag_when_push = not is_con
+
+ mkPushes :: Int{-curr depth-} -> [AnnExpr Id VarSet]
+ -> BcM (Int{-final depth-}, BCInstrList)
+ mkPushes dd []
+ | is_con
+ = returnBc (dd, nilOL)
+ | otherwise
+ = pushAtom False dd p' (AnnVar the_fn) `thenBc` \ (fn_push_code, fn_szw) ->
+ returnBc (dd+fn_szw, fn_push_code)
+ mkPushes dd (atom:atoms)
+ = pushAtom tag_when_push dd p' (snd atom)
+ `thenBc` \ (push1_code, push1_szw) ->
+ mkPushes (dd+push1_szw) atoms `thenBc` \ (dd_final, push_rest) ->
+ returnBc (dd_final, push1_code `appOL` push_rest)
+
+
+-- General case for let. Generates correct, if inefficient, code in
+-- all situations.
schemeE d s p (fvs, AnnLet binds b)
= let (xs,rhss) = case binds of AnnNonRec x rhs -> ([x],[rhs])
AnnRec xs_n_rhss -> unzip xs_n_rhss
n = length xs
- fvss = map (filter (not.isTyVar).varSetElems.fst) rhss
+
+ is_local id = not (isTyVar id) && elemFM id p'
+ fvss = map (filter is_local . varSetElems . fst) rhss
-- Sizes of tagged free vars, + 1 for the fn
sizes = map (\rhs_fvs -> 1 + sum (map taggedIdSizeW rhs_fvs)) fvss
-- ToDo: don't build thunks for things with no free variables
buildThunk dd ([], size, id, off)
- = PUSH_G (Left (getName id))
- `consOL` unitOL (MKAP (off+size-1) size)
+ = returnBc (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
- (push_code, pushed_szw)
- -> push_code `appOL`
- buildThunk (dd+pushed_szw) (fvs, size, id, off)
+ = pushAtom True dd p' (AnnVar fv)
+ `thenBc` \ (push_code, pushed_szw) ->
+ buildThunk (dd+pushed_szw) (fvs, size, id, off)
+ `thenBc` \ more_push_code ->
+ returnBc (push_code `appOL` more_push_code)
+
+ genThunkCode = mapBc (buildThunk d') infos `thenBc` \ tcodes ->
+ returnBc (concatOL tcodes)
- thunkCode = concatOL (map (buildThunk d') infos)
allocCode = toOL (map ALLOC sizes)
+
+ schemeRs [] _ _ = returnBc ()
+ schemeRs (fvs:fvss) (x:xs) (rhs:rhss) =
+ schemeR False fvs (x,rhs) `thenBc_` schemeRs fvss xs rhss
in
schemeE d' s p' b `thenBc` \ bodyCode ->
- mapBc (schemeR False) (zip xs rhss) `thenBc_`
+ schemeRs fvss xs rhss `thenBc_`
+ genThunkCode `thenBc` \ thunkCode ->
returnBc (allocCode `appOL` thunkCode `appOL` bodyCode)
+
+
+
+schemeE d s p (fvs_case, AnnCase (fvs_scrut, scrut) bndr
+ [(DEFAULT, [], (fvs_rhs, rhs))])
+
+ | let isFunType var_type
+ = case splitTyConApp_maybe var_type of
+ Just (tycon,_) | isFunTyCon tycon -> True
+ _ -> False
+ ty_bndr = repType (idType bndr)
+ in isFunType ty_bndr || isTyVarTy ty_bndr
+
+ -- Nasty hack; treat
+ -- case scrut::suspect of bndr { DEFAULT -> rhs }
+ -- as
+ -- let bndr = scrut in rhs
+ -- when suspect is polymorphic or arrowtyped
+ -- So the required strictness properties are not observed.
+ -- At some point, must fix this properly.
+ = let new_expr
+ = (fvs_case,
+ AnnLet
+ (AnnNonRec bndr (fvs_scrut, scrut)) (fvs_rhs, rhs)
+ )
+
+ in trace ("WARNING: ignoring polymorphic case in interpreted mode.\n" ++
+ " Possibly due to strict polymorphic/functional constructor args.\n" ++
+ " Your program may leak space unexpectedly.\n")
+ (schemeE d s p new_expr)
+
+
+
+{- Convert case .... of (# VoidRep'd-thing, a #) -> ...
+ as
+ case .... of a -> ...
+ Use a as the name of the binder too.
+
+ Also case .... of (# a #) -> ...
+ to
+ case .... of a -> ...
+-}
+schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1, bind2], rhs)])
+ | isUnboxedTupleCon dc && VoidRep == typePrimRep (idType bind1)
+ = --trace "automagic mashing of case alts (# VoidRep, a #)" (
+ schemeE d s p (fvs, AnnCase scrut bind2 [(DEFAULT, [bind2], rhs)])
+ --)
+
+schemeE d s p (fvs, AnnCase scrut bndr [(DataAlt dc, [bind1], rhs)])
+ | isUnboxedTupleCon dc
+ = --trace "automagic mashing of case alts (# a #)" (
+ schemeE d s p (fvs, AnnCase scrut bind1 [(DEFAULT, [bind1], rhs)])
+ --)
+
schemeE d s p (fvs, AnnCase scrut bndr alts)
= let
-- Top of stack is the return itbl, as usual.
scrut_primrep = typePrimRep (idType bndr)
isAlgCase
- = case scrut_primrep of
- CharRep -> False ; AddrRep -> False ; WordRep -> False
- IntRep -> False ; FloatRep -> False ; DoubleRep -> False
- VoidRep -> False ;
- PtrRep -> True
- other -> pprPanic "ByteCodeGen.schemeE" (ppr other)
+ | scrut_primrep == PtrRep
+ = True
+ | scrut_primrep `elem`
+ [CharRep, AddrRep, WordRep, IntRep, FloatRep, DoubleRep,
+ VoidRep, Int8Rep, Int16Rep, Int32Rep, Int64Rep,
+ Word8Rep, Word16Rep, Word32Rep, Word64Rep]
+ = False
+ | otherwise
+ = pprPanic "ByteCodeGen.schemeE" (ppr scrut_primrep)
-- given an alt, return a discr and code for it.
codeAlt alt@(discr, binds_f, rhs)
| isAlgCase
= let (unpack_code, d_after_unpack, p_after_unpack)
- = mkUnpackCode binds_f d' p'
+ = mkUnpackCode (filter (not.isTyVar) binds_f) d' p'
in schemeE d_after_unpack s p_after_unpack rhs
`thenBc` \ rhs_code ->
returnBc (my_discr alt, unpack_code `appOL` rhs_code)
(pprCoreExpr (deAnnotate other))
--- Compile code to do a tail call. Three cases:
+-- Compile code to do a tail call. Specifically, push the fn,
+-- slide the on-stack app back down to the sequel depth,
+-- and enter. Four cases:
+--
+-- 0. (Nasty hack).
+-- An application "PrelGHC.tagToEnum# <type> unboxed-int".
+-- The int will be on the stack. Generate a code sequence
+-- to convert it to the relevant constructor, SLIDE and ENTER.
--
-- 1. A nullary constructor. Push its closure on the stack
-- and SLIDE and RETURN.
--
--- 2. Application of a non-nullary constructor, by defn saturated.
+-- 2. (Another nasty hack). Spot (# a::VoidRep, b #) and treat
+-- it simply as b -- since the representations are identical
+-- (the VoidRep takes up zero stack space). Also, spot
+-- (# b #) and treat it as b.
+--
+-- 3. The fn denotes a ccall. Defer to generateCCall.
+--
+-- 4. Application of a non-nullary constructor, by defn saturated.
-- Split the args into ptrs and non-ptrs, and push the nonptrs,
-- then the ptrs, and then do PACK and RETURN.
--
--- 3. Otherwise, it must be a function call. Push the args
+-- 5. Otherwise, it must be a function call. Push the args
-- right to left, SLIDE and ENTER.
schemeT :: Int -- Stack depth
-> Sequel -- Sequel depth
-> BCEnv -- stack env
-> AnnExpr Id VarSet
- -> BCInstrList
+ -> BcM BCInstrList
schemeT d s p app
+
-- | trace ("schemeT: env in = \n" ++ showSDocDebug (ppBCEnv p)) False
-- = panic "schemeT ?!?!"
- -- Handle case 1
+-- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate app)) ++ "\n") False
+-- = error "?!?!"
+
+ -- Case 0
+ | Just (arg, constr_names) <- maybe_is_tagToEnum_call
+ = pushAtom True d p arg `thenBc` \ (push, arg_words) ->
+ implement_tagToId constr_names `thenBc` \ tagToId_sequence ->
+ returnBc (push `appOL` tagToId_sequence
+ `appOL` mkSLIDE 1 (d+arg_words-s)
+ `snocOL` ENTER)
+
+ -- Case 1
| is_con_call && null args_r_to_l
- = (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
- `snocOL` ENTER
+ = returnBc (
+ (PUSH_G (Left (getName con)) `consOL` mkSLIDE 1 (d-s))
+ `snocOL` ENTER
+ )
+
+ -- Case 2
+ | let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
+ 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)
+ )
+ = --trace (if isSingleton args_r_to_l
+ -- then "schemeT: unboxed singleton"
+ -- else "schemeT: unboxed pair with Void first component") (
+ schemeT d s p (head args_r_to_l)
+ --)
- -- Cases 2 and 3
+ -- Case 3
+ | Just (CCall ccall_spec) <- isFCallId_maybe fn
+ = generateCCall d s p ccall_spec fn args_r_to_l
+
+ -- Cases 4 and 5
| otherwise
= if is_con_call && isUnboxedTupleCon con
then unboxedTupleException
- else code
+ else do_pushery d (map snd args_final_r_to_l)
- where
- -- Extract the args (R->L) and fn
- (args_r_to_l_raw, fn) = chomp app
- chomp expr
- = case snd expr of
- AnnVar v -> ([], v)
- AnnApp f a -> case chomp f of (az, f) -> (snd a:az, f)
- AnnNote n e -> chomp e
- other -> pprPanic "schemeT"
- (ppr (deAnnotate (panic "schemeT.chomp", other)))
-
- args_r_to_l = filter (not.isTypeAtom) args_r_to_l_raw
- isTypeAtom (AnnType _) = True
- isTypeAtom _ = False
-
- -- decide if this is a constructor call, and rearrange
- -- args appropriately.
- maybe_dcon = isDataConId_maybe fn
- is_con_call = case maybe_dcon of Nothing -> False; Just _ -> True
- (Just con) = maybe_dcon
-
- args_final_r_to_l
- | not is_con_call
- = args_r_to_l
+ where
+ -- Detect and extract relevant info for the tagToEnum kludge.
+ maybe_is_tagToEnum_call
+ = let extract_constr_Names ty
+ = case splitTyConApp_maybe (repType ty) of
+ (Just (tyc, [])) | isDataTyCon tyc
+ -> map getName (tyConDataCons tyc)
+ other -> panic "maybe_is_tagToEnum_call.extract_constr_Ids"
+ in
+ case app of
+ (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg)
+ -> case isPrimOpId_maybe v of
+ Just TagToEnumOp -> Just (snd arg, extract_constr_Names t)
+ other -> Nothing
+ other -> Nothing
+
+ -- Extract the args (R->L) and fn
+ (args_r_to_l, fn) = chomp app
+ chomp expr
+ = case snd expr of
+ AnnVar v -> ([], v)
+ AnnApp f a
+ | isTypeAtom (snd a) -> chomp f
+ | otherwise -> case chomp f of (az, f) -> (a:az, f)
+ AnnNote n e -> chomp e
+ other -> pprPanic "schemeT"
+ (ppr (deAnnotate (panic "schemeT.chomp", other)))
+
+ n_args = length args_r_to_l
+
+ isTypeAtom (AnnType _) = True
+ isTypeAtom _ = False
+
+ -- decide if this is a constructor application, because we need
+ -- to rearrange the arguments on the stack if so. For building
+ -- a constructor, we put pointers before non-pointers and omit
+ -- the tags.
+ --
+ -- Also if the constructor is not saturated, we just arrange to
+ -- call the curried worker instead.
+
+ maybe_dcon = case isDataConId_maybe fn of
+ Just con | dataConRepArity con == n_args -> Just con
+ _ -> Nothing
+ is_con_call = isJust maybe_dcon
+ (Just con) = maybe_dcon
+
+ args_final_r_to_l
+ | not is_con_call
+ = args_r_to_l
+ | otherwise
+ = filter (not.isPtr.snd) args_r_to_l ++ filter (isPtr.snd) args_r_to_l
+ where isPtr = isFollowableRep . atomRep
+
+ -- make code to push the args and then do the SLIDE-ENTER thing
+ tag_when_push = not is_con_call
+ narg_words = sum (map (get_arg_szw . atomRep . snd) args_r_to_l)
+ get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW
+
+ do_pushery d (arg:args)
+ = pushAtom tag_when_push d p arg `thenBc` \ (push, arg_words) ->
+ do_pushery (d+arg_words) args `thenBc` \ more_push_code ->
+ returnBc (push `appOL` more_push_code)
+ do_pushery d []
+ | Just (CCall ccall_spec) <- isFCallId_maybe fn
+ = panic "schemeT.do_pushery: unexpected ccall"
+ | otherwise
+ = case maybe_dcon of
+ Just con -> returnBc (
+ (PACK con narg_words `consOL`
+ mkSLIDE 1 (d - narg_words - s)) `snocOL`
+ ENTER
+ )
+ Nothing
+ -> pushAtom True d p (AnnVar fn)
+ `thenBc` \ (push, arg_words) ->
+ returnBc (push `appOL` mkSLIDE (narg_words+arg_words)
+ (d - s - narg_words)
+ `snocOL` ENTER)
+
+
+{- Deal with a CCall. Taggedly push the args onto the stack R->L,
+ deferencing ForeignObj#s and (ToDo: adjusting addrs to point to
+ payloads in Ptr/Byte arrays). Then, generate the marshalling
+ (machine) code for the ccall, and create bytecodes to call that and
+ then return in the right way.
+-}
+generateCCall :: Int -> Sequel -- stack and sequel depths
+ -> BCEnv
+ -> CCallSpec -- where to call
+ -> Id -- of target, for type info
+ -> [AnnExpr Id VarSet] -- args (atoms)
+ -> BcM BCInstrList
+
+generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l
+ = let
+ -- useful constants
+ addr_usizeW = untaggedSizeW AddrRep
+ addr_tsizeW = taggedSizeW AddrRep
+
+ -- Get the args on the stack, with tags and suitably
+ -- dereferenced for the CCall. For each arg, return the
+ -- depth to the first word of the bits for that arg, and the
+ -- PrimRep of what was actually pushed.
+
+ pargs d [] = returnBc []
+ pargs d ((_,a):az)
+ = let rep_arg = atomRep a
+ in case rep_arg of
+ -- Don't push the FO; instead push the Addr# it
+ -- contains.
+ ForeignObjRep
+ -> pushAtom False{-irrelevant-} d p a
+ `thenBc` \ (push_fo, _) ->
+ let foro_szW = taggedSizeW ForeignObjRep
+ d_now = d + addr_tsizeW
+ code = push_fo `appOL` toOL [
+ UPK_TAG addr_usizeW 0 0,
+ SLIDE addr_tsizeW foro_szW
+ ]
+ in pargs d_now az `thenBc` \ rest ->
+ returnBc ((code, AddrRep) : rest)
+
+ ArrayRep
+ -> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrPtrsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,AddrRep):rest)
+
+ ByteArrayRep
+ -> pargs (d + addr_tsizeW) az `thenBc` \ rest ->
+ parg_ArrayishRep arrWordsHdrSize d p a
+ `thenBc` \ code ->
+ returnBc ((code,AddrRep):rest)
+
+ -- Default case: push taggedly, but otherwise intact.
+ other
+ -> pushAtom True d p a `thenBc` \ (code_a, sz_a) ->
+ pargs (d+sz_a) az `thenBc` \ rest ->
+ returnBc ((code_a, rep_arg) : rest)
+
+ -- Do magic for Ptr/Byte arrays. Push a ptr to the array on
+ -- the stack but then advance it over the headers, so as to
+ -- point to the payload.
+ parg_ArrayishRep hdrSizeW d p a
+ = pushAtom False{-irrel-} d p a `thenBc` \ (push_fo, _) ->
+ -- The ptr points at the header. Advance it over the
+ -- header and then pretend this is an Addr# (push a tag).
+ returnBc (push_fo `snocOL`
+ SWIZZLE 0 (hdrSizeW * untaggedSizeW PtrRep
+ * wORD_SIZE)
+ `snocOL`
+ PUSH_TAG addr_usizeW)
+
+ in
+ pargs d0 args_r_to_l `thenBc` \ code_n_reps ->
+ let
+ (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps
+
+ push_args = concatOL pushs_arg
+ d_after_args = d0 + sum (map taggedSizeW a_reps_pushed_r_to_l)
+ a_reps_pushed_RAW
+ | null a_reps_pushed_r_to_l || head a_reps_pushed_r_to_l /= VoidRep
+ = panic "ByteCodeGen.generateCCall: missing or invalid World token?"
| otherwise
- = filter (not.isPtr) args_r_to_l ++ filter isPtr args_r_to_l
- where isPtr = isFollowableRep . atomRep
-
- -- make code to push the args and then do the SLIDE-ENTER thing
- code = do_pushery d args_final_r_to_l
-
- tag_when_push = not is_con_call
- narg_words = sum (map (get_arg_szw . atomRep) args_r_to_l)
- get_arg_szw = if tag_when_push then taggedSizeW else untaggedSizeW
-
- do_pushery d (arg:args)
- = let (push, arg_words) = pushAtom tag_when_push d p arg
- in push `appOL` do_pushery (d+arg_words) args
- do_pushery d []
- = case maybe_dcon of
- Just con -> PACK con narg_words `consOL` (
- mkSLIDE 1 (d - narg_words - s) `snocOL` ENTER)
- Nothing
- -> let (push, arg_words) = pushAtom True d p (AnnVar fn)
- in push
- `appOL` mkSLIDE (narg_words+arg_words)
- (d - s - narg_words)
- `snocOL` ENTER
-
-mkSLIDE n d
- = if d == 0 then nilOL else unitOL (SLIDE n d)
+ = reverse (tail a_reps_pushed_r_to_l)
+
+ -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.
+ -- push_args is the code to do that.
+ -- d_after_args is the stack depth once the args are on.
+
+ -- Get the result rep.
+ (returns_void, r_rep)
+ = case maybe_getCCallReturnRep (idType fn) of
+ Nothing -> (True, VoidRep)
+ Just rr -> (False, rr)
+ {-
+ Because the Haskell stack grows down, the a_reps refer to
+ lowest to highest addresses in that order. The args for the call
+ are on the stack. Now push an unboxed, tagged Addr# indicating
+ the C function to call. Then push a dummy placeholder for the
+ result. Finally, emit a CCALL insn with an offset pointing to the
+ Addr# just pushed, and a literal field holding the mallocville
+ address of the piece of marshalling code we generate.
+ So, just prior to the CCALL insn, the stack looks like this
+ (growing down, as usual):
+
+ <arg_n>
+ ...
+ <arg_1>
+ Addr# address_of_C_fn
+ <placeholder-for-result#> (must be an unboxed type)
+
+ The interpreter then calls the marshall code mentioned
+ in the CCALL insn, passing it (& <placeholder-for-result#>),
+ that is, the addr of the topmost word in the stack.
+ When this returns, the placeholder will have been
+ filled in. The placeholder is slid down to the sequel
+ depth, and we RETURN.
+
+ This arrangement makes it simple to do f-i-dynamic since the Addr#
+ value is the first arg anyway. It also has the virtue that the
+ stack is GC-understandable at all times.
+
+ The marshalling code is generated specifically for this
+ call site, and so knows exactly the (Haskell) stack
+ offsets of the args, fn address and placeholder. It
+ copies the args to the C stack, calls the stacked addr,
+ and parks the result back in the placeholder. The interpreter
+ calls it as a normal C call, assuming it has a signature
+ void marshall_code ( StgWord* ptr_to_top_of_stack )
+ -}
+ -- resolve static address
+ get_target_info
+ = case target of
+ DynamicTarget
+ -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)")
+ StaticTarget target
+ -> let sym_to_find = _UNPK_ target in
+ ioToBc (lookupSymbol sym_to_find) `thenBc` \res ->
+ case res of
+ Just aa -> returnBc (True, aa)
+ Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall"
+ sym_to_find)
+ CasmTarget _
+ -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec)
+ in
+ get_target_info `thenBc` \ (is_static, static_target_addr) ->
+ let
+
+ -- Get the arg reps, zapping the leading Addr# in the dynamic case
+ a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"
+ | is_static = a_reps_pushed_RAW
+ | otherwise = if null a_reps_pushed_RAW
+ then panic "ByteCodeGen.generateCCall: dyn with no args"
+ else tail a_reps_pushed_RAW
+
+ -- push the Addr#
+ (push_Addr, d_after_Addr)
+ | is_static
+ = (toOL [PUSH_UBX (Right static_target_addr) addr_usizeW,
+ PUSH_TAG addr_usizeW],
+ d_after_args + addr_tsizeW)
+ | otherwise -- is already on the stack
+ = (nilOL, d_after_args)
+
+ -- Push the return placeholder. For a call returning nothing,
+ -- this is a VoidRep (tag).
+ r_usizeW = untaggedSizeW r_rep
+ r_tsizeW = taggedSizeW r_rep
+ d_after_r = d_after_Addr + r_tsizeW
+ r_lit = mkDummyLiteral r_rep
+ push_r = (if returns_void
+ then nilOL
+ else unitOL (PUSH_UBX (Left r_lit) r_usizeW))
+ `appOL`
+ unitOL (PUSH_TAG r_usizeW)
+
+ -- generate the marshalling code we're going to call
+ r_offW = 0
+ addr_offW = r_tsizeW
+ arg1_offW = r_tsizeW + addr_tsizeW
+ args_offW = map (arg1_offW +)
+ (init (scanl (+) 0 (map taggedSizeW a_reps)))
+ in
+ ioToBc (mkMarshalCode cconv
+ (r_offW, r_rep) addr_offW
+ (zip args_offW a_reps)) `thenBc` \ addr_of_marshaller ->
+ recordMallocBc addr_of_marshaller `thenBc_`
+ let
+ -- do the call
+ do_call = unitOL (CCALL (castPtr addr_of_marshaller))
+ -- slide and return
+ wrapup = mkSLIDE r_tsizeW (d_after_r - r_tsizeW - s)
+ `snocOL` RETURN r_rep
+ in
+ --trace (show (arg1_offW, args_offW , (map taggedSizeW a_reps) )) (
+ returnBc (
+ push_args `appOL`
+ push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup
+ )
+ --)
+
+
+-- Make a dummy literal, to be used as a placeholder for FFI return
+-- values on the stack.
+mkDummyLiteral :: PrimRep -> Literal
+mkDummyLiteral pr
+ = case pr of
+ CharRep -> MachChar 0
+ IntRep -> MachInt 0
+ WordRep -> MachWord 0
+ DoubleRep -> MachDouble 0
+ FloatRep -> MachFloat 0
+ AddrRep | taggedSizeW AddrRep == taggedSizeW WordRep -> MachWord 0
+ _ -> moan64 "mkDummyLiteral" (ppr pr)
+
+
+-- Convert (eg)
+-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
+-- -> (# PrelGHC.State# PrelGHC.RealWorld, PrelGHC.Int# #)
+--
+-- to Just IntRep
+-- and check that an unboxed pair is returned wherein the first arg is VoidRep'd.
+--
+-- Alternatively, for call-targets returning nothing, convert
+--
+-- PrelGHC.Char# -> PrelGHC.State# PrelGHC.RealWorld
+-- -> (# PrelGHC.State# PrelGHC.RealWorld #)
+--
+-- to Nothing
+
+maybe_getCCallReturnRep :: Type -> Maybe PrimRep
+maybe_getCCallReturnRep fn_ty
+ = let (a_tys, r_ty) = splitRepFunTys fn_ty
+ maybe_r_rep_to_go
+ = if isSingleton r_reps then Nothing else Just (r_reps !! 1)
+ (r_tycon, r_reps)
+ = case splitTyConApp_maybe (repType r_ty) of
+ (Just (tyc, tys)) -> (tyc, map typePrimRep tys)
+ Nothing -> blargh
+ ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
+ || r_reps == [VoidRep] )
+ && isUnboxedTupleTyCon r_tycon
+ && case maybe_r_rep_to_go of
+ Nothing -> True
+ Just r_rep -> r_rep /= PtrRep
+ -- if it was, it would be impossible
+ -- to create a valid return value
+ -- placeholder on the stack
+ blargh = pprPanic "maybe_getCCallReturn: can't handle:"
+ (pprType fn_ty)
+ in
+ --trace (showSDoc (ppr (a_reps, r_reps))) (
+ if ok then maybe_r_rep_to_go else blargh
+ --)
atomRep (AnnVar v) = typePrimRep (idType v)
atomRep (AnnLit l) = literalPrimRep l
atomRep other = pprPanic "atomRep" (ppr (deAnnotate (undefined,other)))
+-- Compile code which expects an unboxed Int on the top of stack,
+-- (call it i), and pushes the i'th closure in the supplied list
+-- as a consequence.
+implement_tagToId :: [Name] -> BcM BCInstrList
+implement_tagToId names
+ = ASSERT(not (null names))
+ getLabelsBc (length names) `thenBc` \ labels ->
+ getLabelBc `thenBc` \ label_fail ->
+ getLabelBc `thenBc` \ label_exit ->
+ zip4 labels (tail labels ++ [label_fail])
+ [0 ..] names `bind` \ infos ->
+ map (mkStep label_exit) infos `bind` \ steps ->
+ returnBc (concatOL steps
+ `appOL`
+ toOL [LABEL label_fail, CASEFAIL, LABEL label_exit])
+ where
+ mkStep l_exit (my_label, next_label, n, name_for_n)
+ = toOL [LABEL my_label,
+ TESTEQ_I n next_label,
+ PUSH_G (Left name_for_n),
+ JMP l_exit]
+
+
-- Make code to unpack the top-of-stack constructor onto the stack,
-- adding tags for the unboxed bits. Takes the PrimReps of the
-- constructor's arguments. off_h and off_s are travelling offsets
code_np = do_nptrs vreps_env_uszw ptrs_szw (reverse (map snd vreps_np))
do_nptrs off_h off_s [] = nilOL
do_nptrs off_h off_s (npr:nprs)
- = case npr of
- IntRep -> approved ; FloatRep -> approved
- DoubleRep -> approved ; AddrRep -> approved
- CharRep -> approved
- _ -> pprPanic "ByteCodeGen.mkUnpackCode" (ppr npr)
+ | npr `elem` [IntRep, WordRep, FloatRep, DoubleRep, CharRep, AddrRep]
+ = approved
+ | otherwise
+ = moan64 "ByteCodeGen.mkUnpackCode" (ppr npr)
where
approved = UPK_TAG usizeW (off_h-usizeW) off_s `consOL` theRest
theRest = do_nptrs (off_h-usizeW) (off_s + tsizeW) nprs
-- 5 and not to 4. Stack locations are numbered from zero, so a depth
-- 6 stack has valid words 0 .. 5.
-pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> (BCInstrList, Int)
+pushAtom :: Bool -> Int -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Int)
pushAtom tagged d p (AnnVar v)
| idPrimRep v == VoidRep
- = ASSERT(tagged)
- (unitOL (PUSH_TAG 0), 1)
+ = if tagged then returnBc (unitOL (PUSH_TAG 0), 1)
+ else panic "ByteCodeGen.pushAtom(VoidRep,untaggedly)"
+
+ | isFCallId v
+ = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr 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)
+ = returnBc (unitOL (PUSH_G (Right primop)), 1)
| otherwise
- = let str = "\npushAtom " ++ showSDocDebug (ppr v)
+ = let {-
+ str = "\npushAtom " ++ showSDocDebug (ppr v)
++ " :: " ++ showSDocDebug (pprType (idType v))
++ ", depth = " ++ show d
++ ", tagged = " ++ show tagged ++ ", env =\n" ++
++ " --> words: " ++ show (snd result) ++ "\n" ++
showSDoc (nest 4 (vcat (map ppr (fromOL (fst result)))))
++ "\nendPushAtom " ++ showSDocDebug (ppr v)
- where
- cmp_snd x y = compare (snd x) (snd y)
- str' = if str == str then str else str
+ -}
result
= case lookupBCEnv_maybe p v of
sz_u = untaggedIdSizeW v
nwords = if tagged then sz_t else sz_u
in
- --trace str'
- result
+ returnBc result
pushAtom True d p (AnnLit lit)
- = let (ubx_code, ubx_size) = pushAtom False d p (AnnLit lit)
- in (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
+ = pushAtom False d p (AnnLit lit) `thenBc` \ (ubx_code, ubx_size) ->
+ returnBc (ubx_code `snocOL` PUSH_TAG ubx_size, 1 + ubx_size)
pushAtom False d p (AnnLit lit)
= case lit of
where
code rep
= let size_host_words = untaggedSizeW rep
- in (unitOL (PUSH_UBX lit size_host_words), size_host_words)
+ in returnBc (unitOL (PUSH_UBX (Left lit) size_host_words),
+ size_host_words)
pushStr s
- = let mallocvilleAddr
+ = let getMallocvilleAddr
= case s of
- CharStr s i -> A# s
+ CharStr s i -> returnBc (Ptr s)
FastString _ l ba ->
-- sigh, a string in the heap is no good to us.
-- at the same time.
let n = I# l
-- CAREFUL! Chars are 32 bits in ghc 4.09+
- in unsafePerformIO (
- do (Ptr a#) <- mallocBytes (n+1)
- strncpy (Ptr a#) ba (fromIntegral n)
- writeCharOffAddr (A# a#) n '\0'
- return (A# a#)
+ in ioToBc (mallocBytes (n+1)) `thenBc` \ ptr ->
+ recordMallocBc ptr `thenBc_`
+ ioToBc (
+ do memcpy ptr ba (fromIntegral n)
+ pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8)
+ return ptr
)
- _ -> panic "StgInterp.lit2expr: unhandled string constant type"
-
- addrLit
- = MachInt (toInteger (addrToInt mallocvilleAddr))
+ other -> panic "ByteCodeGen.pushAtom.pushStr"
in
+ getMallocvilleAddr `thenBc` \ addr ->
-- Get the addr on the stack, untaggedly
- (unitOL (PUSH_UBX addrLit 1), 1)
+ returnBc (unitOL (PUSH_UBX (Right addr) 1), 1)
= pprPanic "ByteCodeGen.pushAtom"
(pprCoreExpr (deAnnotate (undefined, other)))
-foreign import "strncpy" strncpy :: Ptr a -> ByteArray# -> CInt -> IO ()
+foreign import "memcpy" memcpy :: Ptr a -> ByteArray# -> CInt -> IO ()
-- Given a bunch of alts code and their discrs, do the donkey work
lookupBCEnv_maybe = lookupFM
--- When I push one of these on the stack, how much does Sp move by?
-taggedSizeW :: PrimRep -> Int
-taggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = 1{-the tag-} + getPrimRepSize pr
-
-
--- The plain size of something, without tag.
-untaggedSizeW :: PrimRep -> Int
-untaggedSizeW pr
- | isFollowableRep pr = 1
- | otherwise = getPrimRepSize pr
-
-
taggedIdSizeW, untaggedIdSizeW :: Id -> Int
taggedIdSizeW = taggedSizeW . typePrimRep . idType
untaggedIdSizeW = untaggedSizeW . typePrimRep . idType
unboxedTupleException :: a
unboxedTupleException
- = throwDyn (Panic "bytecode generator can't handle unboxed tuples")
+ = throwDyn
+ (Panic
+ ("Bytecode generator can't handle unboxed tuples. Possibly due\n" ++
+ "\tto foreign import/export decls in source. Workaround:\n" ++
+ "\tcompile this module to a .o file, then restart session."))
+
+
+mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d)
+bind x f = f x
\end{code}
\begin{code}
data BcM_State
= BcM_State { bcos :: [ProtoBCO Name], -- accumulates completed BCOs
- nextlabel :: Int } -- for generating local labels
+ nextlabel :: Int, -- for generating local labels
+ malloced :: [Ptr ()] } -- ptrs malloced for current BCO
+ -- Should be free()d when it is GCd
+type BcM r = BcM_State -> IO (BcM_State, r)
-type BcM result = BcM_State -> (result, BcM_State)
+ioToBc :: IO a -> BcM a
+ioToBc io st = do x <- io
+ return (st, x)
-runBc :: BcM_State -> BcM () -> BcM_State
-runBc init_st m = case m init_st of { (r,st) -> st }
+runBc :: BcM_State -> BcM r -> IO (BcM_State, r)
+runBc st0 m = do (st1, res) <- m st0
+ return (st1, res)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
-thenBc expr cont st
- = case expr st of { (result, st') -> cont result st' }
+thenBc expr cont st0
+ = do (st1, q) <- expr st0
+ (st2, r) <- cont q st1
+ return (st2, r)
thenBc_ :: BcM a -> BcM b -> BcM b
-thenBc_ expr cont st
- = case expr st of { (result, st') -> cont st' }
+thenBc_ expr cont st0
+ = do (st1, q) <- expr st0
+ (st2, r) <- cont st1
+ return (st2, r)
returnBc :: a -> BcM a
-returnBc result st = (result, st)
+returnBc result st = return (st, result)
+
mapBc :: (a -> BcM b) -> [a] -> BcM [b]
mapBc f [] = returnBc []
mapBc f xs `thenBc` \ rs ->
returnBc (r:rs)
-emitBc :: ProtoBCO Name -> BcM ()
+emitBc :: ([Ptr ()] -> ProtoBCO Name) -> BcM ()
emitBc bco st
- = ((), st{bcos = bco : bcos st})
+ = return (st{bcos = bco (malloced st) : bcos st, malloced=[]}, ())
+
+newbcoBc :: BcM ()
+newbcoBc st
+ | not (null (malloced st))
+ = panic "ByteCodeGen.newbcoBc: missed prior emitBc?"
+ | otherwise
+ = return (st, ())
+
+recordMallocBc :: Ptr a -> BcM ()
+recordMallocBc a st
+ = return (st{malloced = castPtr a : malloced st}, ())
getLabelBc :: BcM Int
getLabelBc st
- = (nextlabel st, st{nextlabel = 1 + nextlabel st})
+ = return (st{nextlabel = 1 + nextlabel st}, nextlabel st)
+
+getLabelsBc :: Int -> BcM [Int]
+getLabelsBc n st
+ = let ctr = nextlabel st
+ in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])
\end{code}
projects / ghc-hetmet.git / blobdiff