Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
  • 10 commits
  • 20 files changed
  • 0 commit comments
  • 1 contributor
Commits on Oct 10, 2012
@nominolo Multi-argument return support in bytecode compiler (WIP)
Code compiles correctly but currently fails when executing.  I need to
change the way the return result is communicated.
5650c79
Commits on Oct 11, 2012
@nominolo Store return results on returning function's stack
The function return result is no longer stored in a the current
thread, but instead on the stack itself.  This makes it
straight-forward to implement multiple return results (with some help
from the bytecode compiler it becomes a no-op -- same as tail call).
Tracing support is not yet implemented but this will also become
easier.
433093e
@nominolo Fix bytecode generation for case-of-unboxed tuple 959e1ec
@nominolo Add explicit invariant check. 27d1aa5
Commits on Oct 12, 2012
@nominolo Explicitly initialise stats_ in Jit constructor
It caused weird errors in the test suite if it was compiled with trace
stats enabled.
e0909ef
@nominolo Adapt trace recording to new return convention 4a4998d
@nominolo Add another test for multiple return arguments. d984b15
@nominolo More helpful error message for out-of-range jumps 9925bb4
@nominolo Properly keep track of main.o dependencies 36c4355
@nominolo Add test case for JIT-compilation of multi-return 11c2430
View
10 Makefile.in
@@ -156,6 +156,8 @@ VM_SRCS = vm/thread.cc vm/capability.cc vm/memorymanager.cc \
vm/machinecode.cc vm/assembler.cc vm/ir.cc vm/ir_fold.cc \
vm/time.cc
+VM_SRCS_ALL = $(VM_SRCS) vm/main.cc
+
TEST_FILES := tests/Bc/Bc0016.lcbc tests/Bc/Bc0014.lcbc \
tests/Bc/Bc0017.lcbc \
tests/Bc/TailCallExact.lcbc tests/Bc/TailCallOverapply.lcbc \
@@ -171,7 +173,9 @@ TEST_FILES := tests/Bc/Bc0016.lcbc tests/Bc/Bc0014.lcbc \
tests/Bc/SumDict.lcbc tests/Bc/SumCall1.lcbc \
tests/Bc/Side0001.lcbc tests/Bc/Side0002.lcbc \
tests/Bc/Side0003.lcbc \
- tests/Bc/RealWorld.lcbc tests/Bc/SharedFail.lcbc
+ tests/Bc/RealWorld.lcbc tests/Bc/SharedFail.lcbc \
+ tests/Bc/MultiReturn.lcbc tests/Bc/MultiReturn2.lcbc \
+ tests/Bc/MultiReturn3.lcbc tests/Bc/MultiReturnJit.lcbc
lcvm: $(VM_SRCS:.cc=.o) vm/main.o
@echo "LINK $(filter %.o %.a, $^) => $@"
@@ -355,7 +359,7 @@ bench-ghc/%: tests/Bench/%.hs
@mkdir -p bench-ghc
$(HC) -O2 -fforce-recomp -DBENCH_GHC $(BENCH_HC_OPTS) -rtsopts -o $@ $<
--include $(SRCS:%.c=$(DEPDIR)/%.P)
+# -include $(SRCS:%.c=$(DEPDIR)/%.P)
-include $(UTILSRCS:%.cc=$(DEPDIR)/%.P)
-include $(DEPDIR)/vm/unittest.P
--include $(VM_SRCS:%.cc=$(DEPDIR)/%.P)
+-include $(VM_SRCS_ALL:%.cc=$(DEPDIR)/%.P)
View
74 compiler/Lambdachine/Ghc/CoreToBC.hs
@@ -43,6 +43,7 @@ module Lambdachine.Ghc.CoreToBC where
import Lambdachine.Builtin
import Lambdachine.Ghc.Utils
import Lambdachine.Grin.Bytecode as Grin
+import Lambdachine.Grin.Analyse ( isVoid )
import Lambdachine.Id as N
import Lambdachine.Utils hiding ( Uniquable(..) )
import Lambdachine.Utils.Unique ( mkBuiltinUnique )
@@ -876,11 +877,14 @@ transVar x env fvi locs0 mr =
-- Note: To avoid keeping track of two environments we must
-- only reach this case if the variable is bound outside the
-- current closure.
- r <- mbFreshLocal (Ghc.repType (Ghc.varType x)) mr
- -- Do not force @i@ -- must remain a thunk
- let i = expectJust "transVar" (Ghc.lookupVarEnv fvi x)
- return (insLoadFV r i, r, in_whnf,
- updateLoc locs0 x (InVar r), closureVar x)
+ if isGhcVoid x then
+ error "Free variables of type void not yet supported."
+ else do
+ r <- mbFreshLocal (Ghc.repType (Ghc.varType x)) mr
+ -- Do not force @i@ -- must remain a thunk
+ let i = expectJust "transVar" (Ghc.lookupVarEnv fvi x)
+ return (insLoadFV r i, r, in_whnf,
+ updateLoc locs0 x (InVar r), closureVar x)
| otherwise -> do -- global variable
this_mdl <- getThisModule
@@ -940,6 +944,7 @@ transApp f args env fvi locs0 ctxt
| isGhcConWorkId f -- allocation
= transStore f args env fvi locs0 ctxt
+
| otherwise
= do (is0, locs1, fvs0, regs) <- transArgs args env fvi locs0
(is1, fr, _, locs2, fvs1)
@@ -961,13 +966,14 @@ transApp f args env fvi locs0 ctxt
BindC mr -> do
-- need to ensure that x = O, so we need to emit
-- a fresh label after the call
- let rslt_ty =
+ let rslt_ty0 =
case splitFunTysN (length args) $
Ghc.repType (Ghc.varType f) of
Just (_arg_tys, rslt_ty_) -> rslt_ty_
Nothing -> error $ "Result type for: " ++
ghcPretty (f, Ghc.repType (Ghc.varType f),
Ghc.varType f, length args)
+ rslt_ty:_ = splitUnboxedTuples rslt_ty0
r <- mbFreshLocal rslt_ty mr
let ins = withFresh $ \l ->
is2 <*> insCall (Just (r, l)) fr regs |*><*| mkLabel l
@@ -1006,6 +1012,27 @@ transStore dcon [] env fvi locs0 ctxt = -- bloody hack Since we only
-- they're basically distinguished pointers.
transBody (Ghc.Var dcon) env fvi locs0 ctxt
+transStore dcon0 args env fvi locs0 ctxt
+ | dcon <- ghcIdDataCon dcon0, Ghc.isUnboxedTupleCon dcon
+ = do
+ case ctxt of
+ BindC _ -> error "Trying to bind an unboxed tuple to a variable"
+ RetC -> do
+ (bcis, locs, fvs, vars0) <- transArgs args env fvi locs0
+ let vars = removeIf isVoid vars0
+ case vars of
+ [res] ->
+ return (bcis <*> insRet1 res, locs, fvs, Nothing)
+ (_:_:_) -> do
+ let
+ resultRegs =
+ [ BcReg n (transType (bcVarType var))
+ | (n, var) <- zip [0..] vars ]
+ bcis' =
+ bcis <*> catGraphs [ insMove reg var
+ | (reg, var) <- zip resultRegs vars ]
+ return (bcis' <*> insRetN resultRegs, locs, fvs, Nothing)
+
transStore dcon args env fvi locs0 ctxt = do
(bcis0, locs1, fvs, regs) <- transArgs args env fvi locs0
@@ -1062,7 +1089,40 @@ transCase :: forall x.
-- Only a single case alternative. This is just EVAL(bndr) and
-- possibly matching on the result.
-transCase scrut bndr alt_ty [(altcon, vars, body)] env0 fvi locs0 ctxt = do
+transCase scrut bndr alt_ty [(altcon, vars, body)] env0 fvi locs0 ctxt
+ | DataAlt con <- altcon, Ghc.isUnboxedTupleCon con
+ = do
+ let nonVoidVars = removeIf isGhcVoid vars
+ (bcis, locs1, fvs0, Just result0) <- transBody scrut env0 fvi locs0 (BindC Nothing)
+
+ if (bndr `isFreeExprVarIn` body) then
+ error "transCase: Binder in unboxed tuple is not a wildcard."
+ else case nonVoidVars of
+ [var] -> do -- effectively only one value is actually returned
+ let locs2 = updateLoc locs1 var (InVar result0)
+ env' = extendLocalEnv env0 var undefined
+ (bcis', locs3, fvs1, mb_r) <- transBody body env' fvi locs2 ctxt
+ return (bcis <*> bcis', locs3, fvs0 `mappend` fvs1, mb_r)
+
+ resultVar0:(otherResultVars@(_:_)) -> do
+ -- Leave `bndr` undefined. It should always be a wildcard.
+ let env' = extendLocalEnvList env0 nonVoidVars
+
+ -- Result variables don't survive across multiple CALL instructions
+ -- so we load them all into fresh variables.
+ regs <- mapM (\x -> mbFreshLocal (Ghc.repType (Ghc.varType x)) Nothing)
+ otherResultVars
+ let bcis1 = [ insLoadExtraResult r n | (r, n) <- zip regs [1..] ]
+ let locs2 = extendLocs locs1 [(resultVar0, InVar result0)]
+ let locs3 = extendLocs locs2
+ [ (x, InVar r) | (x, r) <- zip otherResultVars regs ]
+
+ (bcis', locs4, fvs1, mb_r) <- transBody body env' fvi locs3 ctxt
+ return (bcis <*> catGraphs bcis1 <*> bcis', locs4,
+ fvs0 `mappend` fvs1, mb_r)
+
+ | otherwise
+ = do
(bcis, locs1, fvs0, Just r) <- transBody scrut env0 fvi locs0 (BindC Nothing)
let locs2 = updateLoc locs1 bndr (InVar r)
env = extendLocalEnv env0 bndr undefined
View
34 compiler/Lambdachine/Ghc/Utils.hs
@@ -2,7 +2,7 @@
module Lambdachine.Ghc.Utils where
import Lambdachine.Id as N
-import Lambdachine.Utils.Unique hiding ( Uniquable(..) )
+import Lambdachine.Utils hiding ( Uniquable(..) )
import Lambdachine.Grin.Bytecode as Grin
import Lambdachine.Utils.Pretty
@@ -16,6 +16,10 @@ import qualified Module as Ghc
import qualified Outputable as Ghc
import qualified Type as Ghc
import qualified DataCon as Ghc
+import qualified CoreSyn as Ghc
+import qualified CoreFVs as Ghc
+import qualified Var as Ghc
+import qualified VarSet as Ghc
import Outputable ( Outputable, showPpr, alwaysQualify, showSDocForUser )
import Unique ( Uniquable(..), getKey )
@@ -55,6 +59,34 @@ splitFunTysN n ty = split n ty []
Nothing -> Nothing
Just (arg, ty') -> split (n - 1) ty' (arg:acc)
+isGhcVoid :: Ghc.CoreBndr -> Bool
+isGhcVoid x = isGhcVoidType (Ghc.varType x)
+
+isGhcVoidType :: Ghc.Type -> Bool
+isGhcVoidType ty = transType (Ghc.repType ty) == VoidTy
+
+-- | Split unboxed tuples into their non-void components. Leave
+-- everything else untouched.
+--
+-- > { (# a, b, c #) } ~~> [{ a }, { b }, { c }]
+-- > { (# State# s, Int #) } ~~> [{ Int }]
+-- > { State# s } ~~> [{ State# s #}]
+-- > { Maybe Int } ~~> [{ Maybe Int }]
+-- > { Char } ~~> [{ Char }]
+splitUnboxedTuples :: Ghc.Type -> [Ghc.Type]
+splitUnboxedTuples ty = case Ghc.splitTyConApp_maybe ty of
+ Just (tc, args)
+ | Ghc.isUnboxedTupleTyCon tc -> removeIf isGhcVoidType args
+ _ -> [ty]
+
+isFreeExprVarIn :: Ghc.Id -> Ghc.CoreExpr -> Bool
+isFreeExprVarIn x expr =
+ Ghc.elemVarSet x (ghcFreeExprVars expr)
+
+-- | Return all free variables of the expression (excluding free type variables).
+ghcFreeExprVars :: Ghc.CoreExpr -> Ghc.IdSet
+ghcFreeExprVars = Ghc.exprFreeIds
+
tyConId :: Ghc.Name -> Id
tyConId x =
mkTopLevelId $
View
2  compiler/Lambdachine/Grin/Analyse.hs
@@ -96,6 +96,7 @@ live ins f = case ins of
Eval l _ r -> addOne r (fact f l)
Goto l -> fact f l
Ret1 r -> addOne r (fact_bot livenessLattice)
+ RetN rs -> addLives (fact_bot livenessLattice) rs
CondBranch _ _ r1 r2 tl fl ->
addLives (fact f tl `S.union` fact f fl) [r1, r2]
Case _ r targets ->
@@ -129,6 +130,7 @@ insUses (Assign _ rhs) = universeBi rhs
insUses (Eval _ _ x) = [x]
insUses (Store _ _ x) = [x]
insUses (Ret1 x) = [x]
+insUses (RetN xs) = xs
insUses (CondBranch _ _ x y _ _) = [x, y]
insUses (Case _ x _) = [x]
insUses (Call _ fn args) = fn : args
View
15 compiler/Lambdachine/Grin/Bytecode.hs
@@ -53,6 +53,7 @@ data BcIns' b e x where
Call :: Maybe (BcVar, b, LiveSet)
-> BcVar -> [BcVar] -> BcIns' b O C
Ret1 :: BcVar -> BcIns' b O C
+ RetN :: [BcVar] -> BcIns' b O C
Eval :: b -> LiveSet -> BcVar -> BcIns' b O C
-- only used by the interpreter / RTS
Update :: BcIns' b O C
@@ -90,6 +91,7 @@ data BcTag
data BcRhs
= Move BcVar
+ | HiResult Int -- for loading results of a multi-result return
| Load BcLoadOperand
| BinOp BinOp OpTy BcVar BcVar
| Fetch BcVar Int
@@ -158,6 +160,7 @@ instance NonLocal (BcIns' Label) where
successors (Case _ _ targets) = map (\(_,_,t) -> t) targets
successors (Call mb_l _ _) = maybeToList (snd3 `fmap` mb_l)
successors (Ret1 _) = []
+ successors (RetN _) = []
successors (Eval l _ _) = [l]
instance HooplNode BcIns where
@@ -221,6 +224,8 @@ instance Pretty b => Pretty (BcIns' b e x) where
Just (r,_,_) -> ppr r <+> char '=') <+>
ppr f <> parens (hsep (commaSep (map ppr args)))
ppr (Ret1 r) = text "return" <+> ppr r
+ ppr (RetN rs) =
+ text "return" <+> parens (hsep (commaSep (map ppr rs)))
ppr Update = text "update"
ppr Stop = text "stop"
@@ -237,6 +242,8 @@ instance Pretty BcRhs where
ppr (AllocAp args lives) =
text "alloc_ap(" <> hsep (commaSep (map ppr args)) <> char ')'
<+> pprLives lives
+ ppr (HiResult n) =
+ text "result(" <> ppr n <> char ')'
instance Pretty OpTy where
ppr VoidTy = text "v"
@@ -280,6 +287,7 @@ mapLabels f ins = case ins of
Eval l lv x -> Eval (f l) lv x
Store x n y -> Store x n y
Ret1 x -> Ret1 x
+ RetN xs -> RetN xs
Goto l -> Goto (f l)
CondBranch op ty x y l1 l2 ->
CondBranch op ty x y (f l1) (f l2)
@@ -366,6 +374,9 @@ insMkAp r args = mkMiddle $ Assign r (AllocAp args S.empty)
insMove :: BcVar -> BcVar -> BcGraph O O
insMove dst src = mkMiddle $ Assign dst (Move src)
+insLoadExtraResult :: BcVar -> Int -> BcGraph O O
+insLoadExtraResult dst n = mkMiddle $ Assign dst (HiResult n)
+
insAlloc :: BcVar -> BcVar -> [BcVar] -> BcGraph O O
insAlloc r dcon args = mkMiddle $ Assign r (Alloc dcon args S.empty)
@@ -381,6 +392,9 @@ insEval b r = mkLast $ Eval b S.empty r
insRet1 :: BcVar -> BcGraph O C
insRet1 r = mkLast $ Ret1 r
+insRetN :: [BcVar] -> BcGraph O C
+insRetN results = mkLast (RetN results)
+
insCase :: CaseType -> BcVar -> [(BcTag, BlockId)] -> BcGraph O C
insCase cty r targets =
mkLast $ Case cty r (map (\(t, b) -> (t, S.empty, b)) targets)
@@ -628,6 +642,7 @@ instance Biplate (BcIns' b e x) BcVar where
biplate (Call (Just (x,y,lives)) f args) =
plate (\x' lives' -> Call (Just (x', y, lives'))) |* x |+ lives |* f ||* args
biplate (Ret1 r) = plate Ret1 |* r
+ biplate (RetN rs) = plate RetN ||* rs
biplate l = plate l
instance Biplate (S.Set BcVar) BcVar where
View
11 compiler/Lambdachine/Serialise.hs
@@ -389,6 +389,7 @@ insLength' :: FinalIns -> Int
insLength' ins = case ins of
Lst Stop -> 1
Lst (Ret1 _) -> 1
+ Lst (RetN _) -> 1
Lst (Eval _ _ _) -> 3
Lst (Call Nothing _ (_:args)) -> 1
Lst (Call (Just _) _ (_:args)) -> 3 + arg_len args
@@ -463,6 +464,8 @@ putLinearIns lit_ids new_addrs ins_id ins = case ins of
putIns (insAD opc_STOP 0 0)
Lst (Ret1 (BcReg x _)) ->
putIns (insAD opc_RET1 (i2b x) 0)
+ Lst (RetN regs) ->
+ putIns (insAD opc_RETN (i2b (length (regs))) 0)
Lst (Eval _ lives (BcReg r _))
| Just bitset <- regsToBits (S.delete (BcReg r VoidTy) lives) -> do
putIns (insAD opc_EVAL (i2b r) 0)
@@ -537,7 +540,9 @@ putLinearIns lit_ids new_addrs ins_id ins = case ins of
putIns $ insABC opc_LOADF (i2b d) (i2b n) (i2b fld)
Mid (Store (BcReg ptr _) offs (BcReg src _)) | offs <= 255 ->
putIns $ insABC opc_INITF (i2b ptr) (i2b src) (i2b offs)
- Mid m -> error $ pretty m
+ Mid (Assign (BcReg dst _) (HiResult n)) ->
+ putIns $ insABC opc_MOV_RES (i2b dst) 0 (i2b n)
+ Mid m -> error $ "Cannot serialise: " ++ pretty m
where
binOpOpcode :: OpTy -> BinOp -> Word8
@@ -911,6 +916,8 @@ emitLinearIns bit_r lit_ids tgt_labels r ins_id ins = do
emitInsAD r opc_STOP 0 0
Lst (Ret1 (BcReg x _)) ->
emitInsAD r opc_RET1 (i2b x) 0
+ Lst (RetN regs) ->
+ emitInsAD r opc_RETN (i2b (length regs)) 0
Lst (Eval _ lives (BcReg reg _)) -> do
emitInsAD r opc_EVAL (i2b reg) 0
emitBitSets bit_r (S.delete (BcReg reg VoidTy) lives) r
@@ -986,6 +993,8 @@ emitLinearIns bit_r lit_ids tgt_labels r ins_id ins = do
emitBitSets bit_r lives r
Mid (Assign (BcReg d _) (Fetch (BcReg n _) fld)) ->
emitInsABC r opc_LOADF (i2b d) (i2b n) (i2b fld)
+ Mid (Assign (BcReg dst _) (HiResult n)) ->
+ emitInsAD r opc_MOV_RES (i2b dst) (i2h n)
Mid (Store (BcReg ptr _) offs (BcReg src _)) | offs <= 255 ->
emitInsABC r opc_INITF (i2b ptr) (i2b src) (i2b offs)
Mid m -> error $ pretty m
View
10 compiler/Lambdachine/Utils.hs
@@ -7,7 +7,7 @@ module Lambdachine.Utils
, modify'
, assert
-- * List Utilities
- , fold2l', isLength, collect'
+ , fold2l', isLength, collect', removeIf
-- * Tuple Utilities
, fst3, snd3, thd3,
)
@@ -62,6 +62,14 @@ fold2l' f a0 bs0 cs0 = go a0 bs0 cs0
collect' :: b -> [a] -> (b -> a -> b) -> b
collect' z xs f = foldl' f z xs
+-- | Remove all elements matching the predicate. It is really just a
+-- variant of 'filter' with a name that should prevent some silly
+-- mistakes.
+--
+-- > removeIf odd [1..5]
+removeIf :: (a -> Bool) -> [a] -> [a]
+removeIf pred = filter (\x -> not (pred x))
+
-- | @isLength n xs@ is a lazy equivalent of @length xs == n@. It
-- is lazy in the sense that it evaluates at most @n@ elements of the
-- spine of the list. Examples:
View
52 tests/Bc/MultiReturn.hs
@@ -0,0 +1,52 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, BangPatterns #-}
+{-# OPTIONS_GHC -fobject-code #-}
+module Bc.MultiReturn where
+
+import GHC.Prim
+import GHC.Types
+import GHC.Num
+import GHC.Base
+
+{-# NOINLINE f #-}
+f :: Int -> Int -> (# Int, Int #)
+f x y =
+ let !x' = x + 1
+ y' = y + 3
+ in (# x', y' #)
+
+data A a = A a
+
+-- This only compiles on GHC 7.6+ (and perhapas 7.4). Max added some magic
+-- transformation that auto-converts the types:
+--
+-- (# A1, ..., AN #) -> X ~~> A1 -> ... -> AN -> X
+--
+-- Unfortunately, this conversion seems to occur after CorePrep, so we
+-- have to reproduce it in the bytecode compiler to support newer
+-- versions of GHC. Simple solution: don't support any GHC > 7.0.4
+
+{-
+g :: Int -> Int
+g n = let y = f n n in 42
+
+h :: Bool -> (# Int, Int #) -> (# Int, Int #)
+h b n =
+ let y = n in
+ if b then (# 2, 1 #)
+ else n
+-}
+
+-- This is a kind mismatch:
+{-
+k :: a -> a
+k n = n
+
+k1 = k (# 2, 3 #)
+
+k2 :: (# Int, Int #) -> Int
+k2 n = let a = A n in 42
+-}
+
+test = case f 4 5 of
+ (# (I# n), (I# m) #) ->
+ if n ==# 5# then m ==# 8# else False
View
15 tests/Bc/MultiReturn2.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, BangPatterns #-}
+{-# OPTIONS_GHC -fobject-code #-}
+module Bc.MultiReturn2 where
+
+import GHC.Prim
+import GHC.Types
+import GHC.Num
+import GHC.Base
+
+{-# NOINLINE g #-}
+g :: Int# -> State# RealWorld -> (# State# RealWorld, Int #)
+g n s = (# s, I# (n +# 1#) #)
+
+test = case g 5# realWorld# of
+ (# s', I# m #) -> m ==# 6#
View
15 tests/Bc/MultiReturn3.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, BangPatterns #-}
+{-# OPTIONS_GHC -fobject-code #-}
+module Bc.MultiReturn3 where
+
+import GHC.Prim
+import GHC.Types
+import GHC.Num
+import GHC.Base
+
+{-# NOINLINE g #-}
+g :: Int# -> State# RealWorld -> (# Int, State# RealWorld, Int #)
+g n s = (# I# (n +# 5#), s, I# (n +# 1#) #)
+
+test = case g 5# realWorld# of
+ (# I# x, s', I# y #) -> x ==# 10# && y ==# 6#
View
24 tests/Bc/MultiReturnJit.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE MagicHash, NoImplicitPrelude, UnboxedTuples, BangPatterns #-}
+{-# OPTIONS_GHC -fobject-code #-}
+module Bc.MultiReturnJit where
+
+import GHC.Prim
+import GHC.Types
+import GHC.Num
+import GHC.Base
+
+{-# NOINLINE sumlen #-}
+sumlen :: [Int] -> (# Int, Int #)
+sumlen [] = (# 0, 0 #)
+sumlen (I# x : xs) =
+ case sumlen xs of
+ (# I# s, I# l #) -> (# I# (s +# x), I# (l +# 1#) #)
+
+{-# NOINLINE enumFromTo #-}
+enumFromTo :: Int -> Int -> [Int]
+enumFromTo from@(I# m) to@(I# n) =
+ if m ># n then [] else
+ from : enumFromTo (I# (m +# 1#)) to
+
+test = case sumlen (enumFromTo 1 100) of
+ (# sum_, len_ #) -> sum_ == 5050 && len_ == 100
View
8 vm/assembler.cc
@@ -50,7 +50,13 @@ SpillSet::allocSpillHigh()
static inline int32_t jmprel(MCode *p, MCode *target) {
ptrdiff_t delta = target - p;
- LC_ASSERT(delta == (int32_t)delta);
+ if (!(delta == (int32_t)delta)) {
+ cerr << "FATAL: jmprel: Target out of range p="
+ << (void*)p << " target=" << (void*)target
+ << " delta=" << delta << endl;
+ LC_ASSERT(0 && "jmprel target out of range");
+ exit(1);
+ }
return (int32_t)delta;
}
View
3  vm/bytecode.hh
@@ -19,7 +19,7 @@ _START_LAMBDACHINE_NAMESPACE
_(NEG, RR) \
/* Updates */ \
_(MOV, RR) \
- _(MOV_RES, R) \
+ _(MOV_RES, RN) \
_(UPDATE, RR) \
_(LOADF, RRN) \
_(LOADFV, RN) \
@@ -44,6 +44,7 @@ _START_LAMBDACHINE_NAMESPACE
_(CALL, ___) \
_(CALLT, ___) \
_(RET1, R) \
+ _(RETN, R) \
_(JMP, J) \
_(EVAL, ___) \
_(CASE, ___) \
View
65 vm/capability.cc
@@ -54,9 +54,19 @@ bool isStartOfTrace(BcIns *srcPc, BcIns *dstPc,
branchType == kReturn);
}
-inline
-BcIns *Capability::interpBranch(BcIns *srcPc, BcIns *dstPc, Word *base,
- BranchType branchType) {
+// It's very important that we inline this because it takes so many
+// arguments.
+inline BcIns *
+Capability::interpBranch(BcIns *srcPc, BcIns *dstPc,
+ Word *&base,
+ BranchType branchType,
+ Thread *&T,
+ char *&heap, char *&heaplim,
+ const AsmFunction *&dispatch,
+ const AsmFunction *&dispatch2,
+ const AsmFunction *dispatch_debug,
+ const Code *&code)
+{
#if !LC_JIT
return dstPc;
#else
@@ -67,11 +77,31 @@ BcIns *Capability::interpBranch(BcIns *srcPc, BcIns *dstPc, Word *base,
Fragment *F = jit_.traceAt(dstPc);
if (F != NULL) {
+ // Enter the trace.
if (DEBUG_COMPONENTS & DEBUG_TRACE_RECORDER) {
cerr << COL_YELLOW << "TRACE: " << dstPc << COL_RESET << endl;
}
- // TODO: transfer control to the trace.
+ T->sync(dstPc, base);
+ asmEnter(F->traceId(), T, (Word *)heap, (Word*)heaplim,
+ T->stackLimit(), F->entry());
+ heap = (char *)traceExitHp_;
+ heaplim = (char *)traceExitHpLim_;
+
+ BcIns *pc = NULL;
+ T = currentThread_;
+ dispatch = dispatch_; dispatch2 = dispatch_;
+ base = T->base(); pc = T->pc();
+
+ if (isEnabledBytecodeTracing() ||
+ ((DEBUG_COMPONENTS & DEBUG_TRACE_RECORDER) && isRecording()))
+ dispatch = dispatch_debug;
+
+ // Reload code/KBASE
+ Closure *cl = (Closure *)base[-1];
+ code = ((CodeInfoTable *)cl->info())->code();
+
+ return pc;
} else if (counters_.tick(dstPc)) {
currentThread_->sync(dstPc, base);
@@ -125,7 +155,13 @@ void Capability::finishRecording() {
static inline
bool stackOverflow(Thread *T, Word *top, u4 increment) {
- return T->stackLimit() < (top + increment);
+ // The implementation of EVAL currently needs to simulate a return
+ // from a function. Since we store return results inside the frame
+ // the returned function (i.e., the frame is now unused), we need to
+ // make sure this stack space is valid even if we did not just
+ // return from a function.
+ u4 headroom = FRAME_SIZE + 1;
+ return T->stackLimit() < (top + increment + headroom);
}
// NOTE: Does not check for stack overflow.
@@ -201,7 +237,8 @@ Capability::InterpExitCode Capability::interpMsg(InterpMode mode) {
goto *dispatch[opcode]
# define BRANCH_TO(dst_pc, branch_type) \
- pc = interpBranch(pc, (dst_pc), base, (branch_type)); \
+ pc = interpBranch(pc, (dst_pc), base, (branch_type), \
+ T, heap, heaplim, dispatch, dispatch2, dispatch_debug, code); \
DISPATCH_NEXT;
# define DECODE_BC \
@@ -477,7 +514,7 @@ record: {
}
if (tnode->isHNF()) {
- T->setLastResult((Word)tnode);
+ T->top_[FRAME_SIZE] = (Word)tnode;
++pc; // skip live-out info
DISPATCH_NEXT;
} else {
@@ -517,7 +554,13 @@ op_LOADK: {
op_RET1:
DECODE_AD;
- T->setLastResult(base[opA]);
+ base[0] = base[opA];
+
+op_RETN:
+ // Arguments are already in place. We only add some sanity checks
+ // here.
+ DECODE_AD;
+ LC_ASSERT(&base[opA] <= T->top_);
do_return: {
T->top_ = base - 3;
@@ -536,7 +579,7 @@ do_return: {
}
op_IRET:
- T->setLastResult(base[opA]);
+ base[0] = base[opA];
goto do_return;
op_UPDATE: {
@@ -559,7 +602,7 @@ op_UPDATE: {
op_MOV_RES:
DECODE_AD;
- base[opA] = T->lastResult();
+ base[opA] = T->top_[FRAME_SIZE + opC];
DISPATCH_NEXT;
op_CALL: {
@@ -932,7 +975,7 @@ generic_apply: {
pap->setPayload(i, base[i]);
}
- T->setLastResult((Word)pap);
+ base[0] = (Word)pap;
goto do_return;
}
View
14 vm/capability.hh
@@ -8,6 +8,8 @@
_START_LAMBDACHINE_NAMESPACE
+#define FRAME_SIZE 3
+
typedef enum {
kCall,
kReturn
@@ -61,10 +63,20 @@ private:
kInterpUnimplemented
} InterpExitCode;
+ typedef void *AsmFunction;
+
InterpExitCode interpMsg(InterpMode mode);
+ inline BcIns *interpBranch(BcIns *srcPc, BcIns *dstPc,
+ Word *&base,
+ BranchType branchType,
+ Thread *&T,
+ char *&heap, char *&heaplim,
+ const AsmFunction *&dispatch,
+ const AsmFunction *&dispatch2,
+ const AsmFunction *dispatch_debug,
+ const Code *&code);
BcIns *interpBranch(BcIns *srcPc, BcIns *dst_pc, Word *base, BranchType);
void finishRecording();
- typedef void *AsmFunction;
MemoryManager *mm_;
Thread *currentThread_;
View
73 vm/jit.cc
@@ -59,6 +59,9 @@ Jit::Jit()
Jit::resetFragments();
memset(exitStubGroup_, 0, sizeof(exitStubGroup_));
resetRecorderState();
+#ifdef LC_TRACE_STATS
+ stats_ = NULL;
+#endif
}
Jit::~Jit() {
@@ -85,7 +88,6 @@ void Jit::initRecording(Capability *cap, Word *base, BcIns *startPc)
buf_.reset(base, cap->currentThread()->top());
callStack_.reset();
btb_.reset(startPc_, &callStack_);
- lastResult_ = TRef();
#ifdef LC_TRACE_STATS
stats_ = NULL;
#endif
@@ -321,10 +323,6 @@ bool Jit::recordIns(BcIns *ins, Word *base, const Code *code) {
} else { // We found a true loop.
if (loopentry == 0) {
DBG(cerr << "REC: Loop to entry detected." << endl);
- if (lastResult_.ref() != 0) {
- cerr << "NYI: Pending return result. Cannot compile trace." << endl;
- goto abort_recording;
- }
buf_.emit(IR::kSAVE, IRT_VOID | IRT_GUARD, IR_SAVE_LOOP, 0);
finishRecording();
return true;
@@ -410,12 +408,13 @@ bool Jit::recordIns(BcIns *ins, Word *base, const Code *code) {
Closure *clos = (Closure *)base[ins->a()];
InfoTable *info = clos->info();
TRef iref = buf_.literal(IRT_INFO, (Word)info);
- buf_.setSlot(-1, fnode); // Write to slot before the guard.
+ buf_.emit(IR::kEQINFO, IRT_VOID | IRT_GUARD, fnode, iref);
+
// Clear all non-argument registers.
for (int i = ins->c(); i < code->framesize; ++i) {
buf_.setSlot(i, TRef());
}
- buf_.emit(IR::kEQINFO, IRT_VOID | IRT_GUARD, fnode, iref);
+ buf_.setSlot(-1, fnode); // TODO: Can't write to slot before the guard?
// buf_.slots_.debugPrint(cerr);
uint32_t call_info = (uint32_t)ins->c() | ((uint32_t)ins->b() << 8);
@@ -481,7 +480,9 @@ bool Jit::recordIns(BcIns *ins, Word *base, const Code *code) {
TRef inforef = buf_.literal(IRT_INFO, (Word)tnode->info());
buf_.emit(IR::kEQINFO, IRT_VOID | IRT_GUARD, noderef, inforef);
if (tnode->isHNF()) {
- lastResult_ = noderef;
+ Word *top = cap_->currentThread()->top();
+ int topslot = top - base;
+ buf_.setSlot(topslot + FRAME_SIZE, noderef);
// TODO: Clear dead registers.
} else {
Word *top = cap_->currentThread()->top();
@@ -530,12 +531,13 @@ bool Jit::recordIns(BcIns *ins, Word *base, const Code *code) {
callStack_.returnTo(expectedReturnPc);
TRef resultref = buf_.slot(ins->a());
- lastResult_ = resultref;
// Clear current frame.
for (int i = -3; i < (int)buf_.slots_.top(); ++i) {
buf_.setSlot(i, TRef());
}
+ // Put return result back into frame.
+ buf_.setSlot(0, resultref);
// Return address implies framesize, thus we don't need an extra
// guard. In fact, storing all these frame pointers on the stack
@@ -551,18 +553,45 @@ bool Jit::recordIns(BcIns *ins, Word *base, const Code *code) {
break;
}
- case BcIns::kMOV_RES: {
- if (!(IRRef)lastResult_) {
-#if !defined(NDEBUG)
- logNYI(NYI_RECORD_MOV_RES_EXT);
-#endif
+ case BcIns::kRETN: {
+ TRef retref = buf_.slot(-2);
+ TRef expectedReturnPc = buf_.literal(IRT_PC, base[-2]);
+ buf_.emit(IR::kEQ, IRT_VOID | IRT_GUARD, retref, expectedReturnPc);
+
+ callStack_.returnTo(expectedReturnPc);
+
+ // Clear current frame, except for the return results.
+ for (int i = -3; i < 0; ++i) {
+ buf_.setSlot(i, TRef());
+ }
+
+ for (int i = ins->a(); i < (int)buf_.slots_.top(); ++i) {
+ buf_.setSlot(i, TRef());
+ }
+
+ // Return address implies framesize, thus we don't need an extra
+ // guard. In fact, storing all these frame pointers on the stack
+ // is quite wasteful.
+ Word *newbase = (Word *)base[-3];
+ if (!buf_.slots_.frame(newbase, base - 3)) {
+ cerr << "Abstract stack overflow/underflow" << endl;
goto abort_recording;
}
- buf_.setSlot(ins->a(), lastResult_);
- // Clear lastResult_. If lastResult_ is not cleared at the end of
- // a trace we have a pending return result and cannot compile the
- // trace (ATM).
- lastResult_ = TRef();
+
+ flags_.set(kLastInsWasBranch);
+ break;
+ }
+
+ case BcIns::kMOV_RES: {
+ // NOTE: We rely on the top pointer to be correct.
+ int topslot = buf_.slots_.top();
+ int resultslot = topslot + FRAME_SIZE + ins->d();
+ TRef result = buf_.slot(resultslot);
+ // Clear old value to avoid unnecessarily creating a snapshot
+ // entry for it. The bytecode compiler never emits a MOV_RES
+ // twice for the same input.
+ buf_.setSlot(resultslot, TRef());
+ buf_.setSlot(ins->a(), result);
break;
}
@@ -750,14 +779,16 @@ void Jit::finishRecording() {
Fragment *F = saveFragment();
registerFragment(startPc_, F);
- resetRecorderState();
if (parent_ != NULL) {
asm_.patchGuard(parent_, parentExitNo_, F->entry());
- } else {
+ } else if (!flags_.get(kIsReturnTrace)) {
+ cerr << "Writing JFUNC (" << flags_.get(kIsReturnTrace) << ")\n";
*startPc_ = BcIns::ad(BcIns::kJFUNC, 0, tno);
}
+ resetRecorderState();
+
DBG( {
ofstream out;
stringstream filename;
View
1  vm/jit.hh
@@ -218,7 +218,6 @@ private:
ExitNo parentExitNo_;
Flags32 flags_; // reset each time
Flags32 options_; // configuration options
- TRef lastResult_;
std::vector<BcIns*> targets_;
Prng prng_;
MachineCode mcode_;
View
1  vm/thread.cc
@@ -24,7 +24,6 @@ void Thread::initialize(Word stackSizeInWords) {
base_ = NULL;
top_ = NULL;
owner_ = NULL;
- lastResult_ = 0;
stack_ = NULL;
if (stackSizeInWords < kMinStackWords) {
stackSizeInWords = kMinStackWords;
View
3  vm/thread.hh
@@ -30,8 +30,6 @@ public:
base_[n] = value;
}
- inline Word lastResult() const { return lastResult_; }
- inline void setLastResult(Word value) { lastResult_ = value; }
inline void setPC(BcIns *pc) { pc_ = pc; }
// Thread() {}
@@ -53,7 +51,6 @@ public:
Word stackSize_;
Word *base_;
Word *top_;
- Word lastResult_;
Word *stack_;
Capability *owner_;
};
View
16 vm/unittest.cc
@@ -1077,6 +1077,22 @@ TEST_F(RunFileTest, SharedFail) {
run("Bc.SharedFail");
}
+TEST_F(RunFileTest, MultiReturn) {
+ run("Bc.MultiReturn");
+}
+
+TEST_F(RunFileTest, MultiReturn2) {
+ run("Bc.MultiReturn2");
+}
+
+TEST_F(RunFileTest, MultiReturn3) {
+ run("Bc.MultiReturn3");
+}
+
+TEST_F(RunFileTest, MultiReturnJit) {
+ run("Bc.MultiReturnJit");
+}
+
TEST(HotCounters, Simple) {
HotCounters counters(5);
BcIns pc[] = { BcIns::ad(BcIns::kFUNC, 3, 0) };

No commit comments for this range

Something went wrong with that request. Please try again.