Skip to content

Commit

Permalink
work on CoreRun explicit stack runner, just a commit before the weeke…
Browse files Browse the repository at this point in the history 
…nd...
  • Loading branch information
@atzedijkstra
atzedijkstra committed Oct 31, 2014
1 parent 7f1ae1d commit 26f73ad
Show file tree
Hide file tree
Showing 5 changed files with 58 additions and 50 deletions.
28 changes: 6 additions & 22 deletions EHC/src/ehc/Core/ToCoreRun.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -129,6 +129,7 @@ SEM CBound
| isNotWHNF -> ToBe_Thunked
_ -> ToBe_LeftAsIs
. isToBeThunked = @toBe == ToBe_Thunked
. isToBeALam = @isToBeThunked || whatExprIsLam @expr.whatBelow
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand Down Expand Up @@ -183,24 +184,6 @@ SEM CPatFld
| Fld loc . tailCtx = TailCtx_Plain
%%]

%%[(8888 corerun)
ATTR CExpr AllAlt [ isTailRec: Bool | | ]

SEM CModule
| Mod loc . isTailRec = False

SEM CBound
| Bind Val loc . isTailRec = @isToBeThunked
| FFE loc . isTailRec = False

SEM CExpr
| Lam body . isTailRec = True
| App loc . isTailRec = False

SEM CPatFld
| Fld loc . isTailRec = False
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% Offsets for references
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand Down Expand Up @@ -269,8 +252,8 @@ SEM CModule
| Mod expr . stackDepth = 0

SEM CBound
| Bind Val expr . stackDepth = if @isToBeThunked then 0 else @lhs.stackDepth
loc . stackDepthExpr = if @isToBeThunked then @lhs.stackDepth+1 else @expr.stackDepth
| Bind Val expr . stackDepth = if @isToBeALam then 0 else @lhs.stackDepth
loc . stackDepthExpr = if @isToBeALam then @lhs.stackDepth+1 else @expr.stackDepth
lhs . stackDepth = @stackDepthExpr

{-
Expand Down Expand Up @@ -310,7 +293,7 @@ SEM CAlt
SEM CBound
| Bind Val loc . stackDepthMaxThunked
= max @expr.stackDepth @expr.stackDepthMax
lhs . stackDepthMax = if @isToBeThunked then @stackDepthExpr else @stackDepthMaxThunked
lhs . stackDepthMax = if @isToBeALam then @stackDepthExpr else @stackDepthMaxThunked
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand Down Expand Up @@ -547,7 +530,8 @@ SEM CPat
ATTR CodeAGItf CModule [ | | crm: {CR.Mod} ]

SEM CModule
| Mod lhs . crm = CR.Mod_Mod (CR.nm2RefMpInverse @nm2refNew) @moduleNm @lhs.modNr (CR.mkCRArray $ map snd @expr.crb) ({- CR.Exp_Ret $ -} CR.Exp_Force @creMod)
| Mod loc . crmBinds = CR.mkCRArray $ map snd @expr.crb
lhs . crm = CR.Mod_Mod (CR.nm2RefMpInverse @nm2refNew) @moduleNm @lhs.modNr (@expr.stackDepthMax {- - CR.craLength @crmBinds -}) @crmBinds (CR.Exp_Force @creMod)
%%]


Expand Down
1 change: 1 addition & 0 deletions EHC/src/ehc/CoreRun/AbsSyn.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@ DATA Mod
| Mod ref2nm : {Ref2Nm} -- inverse lookup of locally introduced binding RRef's
moduleNm : {HsName}
moduleNr : {Int} -- sequence nr, index later into global table of modules
stkDepth : {Int} -- max depth of stack for setting up globals
binds : {CRArray Bind}
body : Exp
%%]
Expand Down
4 changes: 2 additions & 2 deletions EHC/src/ehc/CoreRun/Pretty.cag
View file
Original file line number Diff line number Diff line change
Expand Up @@ -165,7 +165,7 @@ ppBinds = ppBinds' 0
ATTR AllNT [ | | pp USE {>-<} {empty} : PP_Doc ]

SEM Mod
| Mod lhs . pp = "module" >#< @moduleNm >|< ":" >#< @body.pp
| Mod lhs . pp = "module" >#< @moduleNm >#< ppCommas [@moduleNr, @stkDepth] >|< ":" >#< @body.pp
>-< ppBinds'' @inhpp (RRef_Glb @moduleNr) 0 @binds

SEM SExp
Expand All @@ -185,7 +185,7 @@ SEM Exp
| RetCase lhs . pp = "retcase" >|< @nrBinds >|< ppParens @expr.pp
| Tail lhs . pp = "tail" >|< ppParens @expr.pp
-- | Thunk lhs . pp = "thunk" >|< ppParens @expr.pp
| Lam lhs . pp = "\\" >|< "@" >|< @lev >#< (if @nrArgs > 0 then pp @nrArgs else pp "thk") >|< "," >|< @nrBinds >|< "," >|< @stkDepth >#< "->" >#< @body.pp
| Lam lhs . pp = "\\" >|< "@" >|< @lev >#< ppCommas [if @nrArgs > 0 then pp @nrArgs else pp "thk", pp @nrBinds, pp @stkDepth] >#< "->" >#< @body.pp
| Case lhs . pp = "case" >#< @expr.pp >#< "of"
>-< indent 1 (vlist $ map (ppAlt'' @lhs.inhpp) $ V.toList @alts)
| Tup lhs . pp = "alloc" >#< ctagTag @tag >|< ppParensCommas (map (ppExp'' @lhs.inhpp) $ V.toList @args)
Expand Down
19 changes: 12 additions & 7 deletions EHC/src/ehc/CoreRun/Run/Val.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -717,9 +717,10 @@ dumpPpEnvM extensive = do
else return $ header2
where
dumpFrame fp = do
fr@(RVal_Frame {rvalFrVals=vs}) <- heapGetM fp
pps <- ppa (MV.length vs) vs
return $ "Frame ptr=" >|< fp >-< (indent 2 $ fr >-< (indent 2 $ vlist pps))
fr@(RVal_Frame {rvalFrVals=vs, rvalFrSP=spref}) <- heapGetM fp
sp <- liftIO $ readIORef spref
pps <- ppa sp vs
return $ "Frame ptr=" >|< fp >|< " sp=" >|< sp >-< (indent 2 $ fr >-< (indent 2 $ vlist pps))
dumpGlobals glbls = do
pps <- forM [0 .. V.length glbls - 1] $ \i -> do
dumpFrame (glbls V.! i)
Expand Down Expand Up @@ -835,12 +836,16 @@ renvFrStkReversePopMV sz = (liftIO $ mvecAlloc sz) >>= \vs -> renvFrStkReversePo
%%% Tracing
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

%%[(8 corerun) hs export(rsemTr)
%%[(8 corerun) hs export(rsemTr', rsemTr)
-- | Trace
rsemTr :: (PP msg, RunSem RValCxt RValEnv RVal m x) => msg -> RValT m ()
rsemTr msg = whenM (gets renvDoTrace) $ do
rsemTr' :: (PP msg, RunSem RValCxt RValEnv RVal m x) => Bool -> msg -> RValT m ()
rsemTr' dumpExtensive msg = whenM (gets renvDoTrace) $ do
liftIO $ putStrLn $ show $ pp msg
dumpEnvM False
dumpEnvM dumpExtensive

-- | Trace
rsemTr :: (PP msg, RunSem RValCxt RValEnv RVal m x) => msg -> RValT m ()
rsemTr = rsemTr' False
%%]

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Expand Down
56 changes: 37 additions & 19 deletions EHC/src/ehc/CoreRun/Run/Val/RunExplStk.chs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,11 +38,18 @@
-- | Allocate a new frame
explStkAllocFrameM :: (RunSem RValCxt RValEnv RVal m x) => Ref2Nm -> HpPtr -> Int -> Int -> Int -> RValT m HpPtr
explStkAllocFrameM r2n sl lev sz nrArgs = do
rsemTr' True $ "explStkAllocFrameM 1 sz=" ++ show sz ++ " nrArgs=" ++ show nrArgs
a <- liftIO $ mvecAllocInit sz
rsemTr' True $ "explStkAllocFrameM 2"
renvFrStkReversePopInMV 0 nrArgs a
rsemTr' True $ "explStkAllocFrameM 3"
slref <- liftIO $ newIORef sl
rsemTr' True $ "explStkAllocFrameM 4"
spref <- liftIO $ newIORef nrArgs
heapAllocM $ RVal_Frame r2n slref lev a spref
rsemTr' True $ "explStkAllocFrameM 5"
p <- heapAllocM $ RVal_Frame r2n slref lev a spref
rsemTr' True $ "explStkAllocFrameM 6"
return p

-- | Allocate and push a new stack frame
explStkPushAllocFrameM :: (RunSem RValCxt RValEnv RVal m x) => Ref2Nm -> HpPtr -> Int -> Int -> Int -> RValT m ()
Expand All @@ -64,18 +71,18 @@ explStkReplaceAllocFrameM r2n sl lev sz nrArgs = do
{-# INLINE explStkReplaceAllocFrameM #-}

-- | Pop a stack frame, copying the top of the stack embedded in the frame
explStkPopFrameM :: (RunSem RValCxt RValEnv RVal m x) => RValT m ()
explStkPopFrameM :: (RunSem RValCxt RValEnv RVal m x) => RValT m HpPtr
explStkPopFrameM = do
v <- renvFrStkPop1
(RValEnv {renvStack=st, renvTopFrame=tf}) <- get
(RValEnv {renvStack=stref, renvTopFrame=tfref}) <- get
liftIO $ do
stk <- readIORef st
tf <- readIORef tfref
stk <- readIORef stref
case stk of
[] -> writeIORef tf nullPtr
[] -> writeIORef tfref nullPtr
(h:t) -> do
writeIORef tf h
writeIORef st t
renvFrStkPush1 v
writeIORef tfref h
writeIORef stref t
return tf
{-# INLINE explStkPopFrameM #-}
%%]

Expand Down Expand Up @@ -113,7 +120,9 @@ rvalExplStkAppLam sl f nrActualArgs failcont = do
then do
explStkPushAllocFrameM r2n sl l sz nrActualArgs
rsemExp b
v <- renvFrStkPop1
explStkPopFrameM
renvFrStkPush1 v
else do
explStkReplaceAllocFrameM r2n sl l sz nrActualArgs
mustReturn $ rsemExp b
Expand Down Expand Up @@ -155,7 +164,7 @@ rvalExplStkExp :: RunSem RValCxt RValEnv RVal m () => Exp -> RValT m ()
{-# SPECIALIZE rvalExplStkExp :: RunSem RValCxt RValEnv RVal IO () => Exp -> RValT IO () #-}
-- {-# INLINE rvalExplStkExp #-}
rvalExplStkExp e = do
-- rsemTr $ "E:" >#< e
rsemTr' True $ "E:" >#< e
-- e' <- case e of
case e of
-- app, call
Expand Down Expand Up @@ -216,24 +225,33 @@ instance
) => RunSem RValCxt RValEnv RVal m ()
where
-- {-# SPECIALIZE instance RunSem RValCxt RValEnv RVal IO () #-}
{-
rsemInitial = do
s <- liftIO $ newRValEnv 100000
return (emptyRValCxt, s, undefined)

rsemSetup opts modImpL mod = {- local (const emptyRValCxt) $ -} do
-- (liftIO $ newRValEnv 100000) >>= put
let modAllL = mod : modImpL
rsemSetup opts modImpL mod = do
rsemSetTrace True
rsemTr' True $ "Setup 1"
let modAllL = modImpL ++ [mod]
rsemTr' True $ "Setup 2"
ms <- liftIO $ MV.new (maximum (map moduleNr_Mod_Mod modAllL) + 1)
forM_ modAllL $ \(Mod_Mod {ref2nm_Mod_Mod=r2n, moduleNr_Mod_Mod=nr, binds_Mod_Mod=bs}) -> do
bs' <- (liftIO . V.thaw) =<< V.forM bs rsemExp
p <- implStkAllocFrameM r2n nullPtr 0 (MV.length bs') bs'
rsemTr' True $ "Setup 3"
forM_ modAllL $ \(Mod_Mod {ref2nm_Mod_Mod=r2n, moduleNr_Mod_Mod=nr, binds_Mod_Mod=bs, stkDepth_Mod_Mod=sz}) -> do
rsemTr' True $ "Setup 4"
explStkPushAllocFrameM r2n nullPtr 0 sz 0
rsemTr' True $ "Setup 5"
V.forM_ bs rsemExp
rsemTr' True $ "Setup 6"
p <- explStkPopFrameM
rsemTr' True $ "Setup 7"
liftIO $ MV.write ms nr p
rsemTr' True $ "Setup 8"
rsemTr' True $ "Setup 9"
ms' <- liftIO $ V.freeze ms
rsemTr' True $ "Setup 10"
modify $ \env -> env {renvGlobals = ms'}
rsemTr' True $ "Setup 11"
rsemSetTrace $ CoreOpt_RunTrace `elem` ehcOptCoreOpts opts
-- return RVal_None
-}

rsemSetTrace doTrace = modify $ \env ->
env {renvDoTrace = doTrace}
Expand Down

0 comments on commit 26f73ad

Please sign in to comment.