[improve code generation in various ways, introduce promote and demote, switch statement to use Data.Sequence
John Meacham <john@repetae.net>**20070517113054] hunk ./C/FromGrin2.hs 207
-       return (annotate (show as) (label (toName (show name ++ show u))) & indentBlock ss)
+       return (annotate (show as) (label (toName (show name ++ show u))) & subBlock ss)
hunk ./C/FromGrin2.hs 310
+convertBody (Error s t) = do
+    x <- asks rTodo
+    let jerr | null s    = expr $ functionCall (name "jhc_exit") [constant $ number 255]
+             | otherwise = expr $ functionCall (name "jhc_error") [string s]
+    let f (TyPtr _) = return nullPtr
+        f TyNode = return nullPtr
+        f (TyTup []) = return emptyExpression
+        f (TyTup xs) = do ts <- mapM convertType xs; xs <- mapM f xs ; return $ structAnon (zip xs ts)
+        f (Ty x) = return $ cast (basicType (show x)) (constant $ number 0)
+        f TyTag  = return $ constant (enum $ nodeTagName tagHole)
+        f x = return $ err ("error-type " ++ show x)
+    case x of
+        TodoNothing -> return jerr
+        TodoExp _ -> return jerr
+        TodoReturn -> do
+            v <- f t
+            return (jerr & creturn v)
+
+convertBody (Store  n@NodeC {})  = newNode n >>= \(x,y) -> simpleRet (cast sptr_t y) >>= \v -> return (x & v)
+convertBody (Return n@NodeC {})  = newNode n >>= \(x,y) -> simpleRet (cast wptr_t y) >>= \v -> return (x & v)
+
+-- IORef's do this
+convertBody (Store v) | tyINode == getType v = do
+    v <- convertVal v
+    tmp <- newVar (ptrType sptr_t)
+    r <- simpleRet tmp
+    return ((tmp =* jhc_malloc (sizeof sptr_t)) & (dereference tmp =* v) & r)
+convertBody (Fetch v) | getType v == TyPtr tyINode  = do
+    v <- convertVal v
+    simpleRet $ dereference v
+convertBody (Update v z) | getType z == tyINode = do
+    v' <- convertVal v
+    z' <- convertVal z
+    r <- simpleRet emptyExpression
+    return (dereference v' =* z' & r)
+
+-- return, promote and demote
+convertBody (Fetch v)        | getType v == tyINode = simpleRet =<< f_promote `liftM` convertVal v
+convertBody (Store n@Var {}) | getType n == tyDNode = simpleRet =<< f_demote `liftM` convertVal n
+convertBody (Return v) = simpleRet =<< convertVal v
hunk ./C/FromGrin2.hs 355
+    r <- simpleRet er
+    return (ss & r)
+
+
+simpleRet er = do
+    x <- asks rTodo
hunk ./C/FromGrin2.hs 362
-        TodoReturn -> return (ss & creturn er)
-        TodoExp v | isEmptyExpression er -> return ss
-        TodoExp v -> return (ss & (v =* er))
-        TodoNothing | isEmptyExpression er -> return ss
-        TodoNothing -> return (ss & er)
+        TodoReturn -> return (creturn er)
+        _ | isEmptyExpression er -> return mempty
+        TodoExp v -> return (v =* er)
+        TodoNothing -> return $ expr er
hunk ./C/FromGrin2.hs 378
-convertExp (Error s t) = do
-    let f (TyPtr _) = return nullPtr
-        f TyNode = return nullPtr
-        f (TyTup []) = return emptyExpression
-        f (TyTup xs) = do ts <- mapM convertType xs; xs <- mapM f xs ; return $ structAnon (zip xs ts)
-        f (Ty x) = return $ cast (basicType (show x)) (constant $ number 0)
-        f TyTag  = return $ constant (enum $ nodeTagName tagHole)
-        f x = return $ err $ "error-type " ++ show x
-    ev <- f t
-    if null s
-      then return (expr $ functionCall (name "jhc_exit") [constant $ number 255],ev)
-       else return (expr $ functionCall (name "jhc_error") [string s],ev)
hunk ./C/FromGrin2.hs 391
-convertExp (Store v) | TyPtr TyNode == getType v = do
-    v <- convertVal v
-    tmp <- newVar (ptrType sptr_t)
-    return ((tmp =* jhc_malloc (sizeof sptr_t)) & (dereference tmp =* v),tmp)
-convertExp (Fetch v) | getType v == TyPtr (TyPtr TyNode) = do
-    v <- convertVal v
-    return (mempty,dereference v)
-convertExp (Fetch v) | getType v == TyPtr TyNode = do
-    v <- convertVal v
-    return (mempty,f_fetch v)
-convertExp (Update v z) | getType z == TyPtr TyNode = do
-    v' <- convertVal v
-    z' <- convertVal z
-    return $ (dereference v' =* z',emptyExpression)
+
+
hunk ./C/FromGrin2.hs 400
-convertExp (Store n@NodeC {})  = newNode n >>= \(x,y) -> return (x,cast sptr_t y)
-convertExp (Return n@NodeC {}) = newNode n >>= \(x,y) -> return (x,cast wptr_t y)
-convertExp (Store n@Var {}) | getType n == TyNode = do
-    n' <- convertVal n
-    return (mempty,cast sptr_t n')
-convertExp (Return v) = do
-    v <- convertVal v
-    return (mempty,v)
---convertExp (App a vs _) | a `notElem` [funcApply,funcEval] = do
hunk ./C/FromGrin2.hs 679
-f_fetch e     = functionCall (name "fetch") [e]
+f_promote e   = functionCall (name "promote") [e]
+f_demote e    = functionCall (name "demote") [e]
+f_follow e    = functionCall (name "follow") [e]
hunk ./C/FromGrin2.hs 813
+
hunk ./C/Generate.hs 27
-    indentBlock,
+    subBlock,
hunk ./C/Generate.hs 60
+import Data.List(intersperse)
+import Data.Maybe(isNothing)
hunk ./C/Generate.hs 63
-import List(intersperse)
-import Maybe(isNothing)
hunk ./C/Generate.hs 64
-import qualified Data.Map as Map
hunk ./C/Generate.hs 65
+import qualified Data.Foldable as Seq
+import qualified Data.Map as Map
+import qualified Data.Sequence as Seq
+import qualified Data.Traversable as Seq
+import qualified Data.Set as Set
hunk ./C/Generate.hs 72
-import GenUtil
+import Util.Gen
+import Util.SetLike
+
+data Env = Env {
+    envUsedLabels :: Set.Set Name,
+    envInScope    :: Set.Set Name
+    }
hunk ./C/Generate.hs 80
+emptyEnv = Env { envUsedLabels = mempty, envInScope = mempty }
hunk ./C/Generate.hs 82
-newtype G a = G (RWS () [(Name,Type)] (Int,Map.Map [Type] Name) a)
-    deriving(Monad,MonadWriter [(Name,Type)],MonadState (Int,Map.Map [Type] Name))
+newtype G a = G (RWS Env [(Name,Type)] (Int,Map.Map [Type] Name) a)
+    deriving(Monad,MonadWriter [(Name,Type)],MonadState (Int,Map.Map [Type] Name),MonadReader Env)
hunk ./C/Generate.hs 93
-data StatementInfo = StatementGoto Name | StatementLabel Name | StatementNoInfo | StatementEmpty
hunk ./C/Generate.hs 96
-data Statement = SD StatementInfo (G Doc)
+
+newtype Statement = St (Seq.Seq Stmt)
+
+data Stmt =
+    SD (G Doc)
+    | SGoto Name
+    | SLabel Name
+    | SReturn Expression
+    | SBlock Statement
+    | SIf Expression Statement Statement
+    | SSwitch Expression [(Maybe Constant,Statement)]
+
hunk ./C/Generate.hs 110
-sd = SD StatementNoInfo
+sd x = stmt (SD x)
+stmt s = St (Seq.singleton s)
+
+stmtMapStmt :: Monad m => (Stmt -> m Stmt) -> Stmt -> m Stmt
+stmtMapStmt f s = g s where
+    g (SBlock sb) = return SBlock `ap` h sb
+    g (SIf e s1 s2) = return (SIf e) `ap` h s1 `ap` h s2
+    g (SSwitch e ss) = do
+        ss <- forM ss $ \ (x,y) -> do
+            y <- h y
+            return (x,y)
+        return $ SSwitch e ss
+    g s = return s
+    h (St sms) = return St `ap` Seq.mapM f sms
+
hunk ./C/Generate.hs 141
-    draw (SD _ g) = g
+    draw (St ss) = vcat (map draw $ Seq.toList ss)
hunk ./C/Generate.hs 144
+instance Draw Stmt where
+    err s = SD (terr s)
+
+    draw (SD g) = g
+    draw (SReturn e) | isEmptyExpression e = text "return;"
+    draw (SReturn e) = text "return " <> draw e <> char ';'
+    draw (SLabel n@(Name s)) = do
+        ls <- asks envUsedLabels
+        if n `member` ls then  text s <> char ':' else return mempty
+    draw (SGoto (Name s)) = text "goto" <+> text s <> char ';'
+    draw (SBlock s) = do
+        s <- subBlockBody s
+        return $ vcat [char '{', nest 4 s, char '}']
+    draw (SIf exp thn els) = do
+        exp <- draw exp
+        thn <- subBlockBody thn
+        els <- subBlockBody els
+        return $ text "if" <+> parens exp <+> lbrace <$> nest 4 thn <$> rbrace <+> text "else" <+> lbrace <$> nest 4 els <$> rbrace
+    draw (SSwitch e ts) = text "switch" <+> parens (draw e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where
+        sc (Just x,ss) = do ss <- draw ss ; x <- draw x; return $ text "case" <+> x <> char ':' $$ nest 4 (ss $$ text "break;")
+        sc (Nothing,ss) = do ss <- draw ss; return $ text "default:"  $$  ( nest 4 ss $$ text "break;")
+        md = if any isNothing (fsts ts) then empty else text "default: jhc_case_fell_off(__LINE__);"
+
+subBlockBody s = draw s
+
hunk ./C/Generate.hs 247
+instance Monoid Statement where
+    mempty = St mempty
+    mappend (St as) (St bs) = St $ pairOpt stmtPairOpt as bs
+
+stmtPairOpt a b = f a b where
+    f (SGoto l) y@(SLabel l') | l == l' = Just y
+    f SReturn {} SLabel {} = Nothing
+    f x@SGoto {} _  = Just x
+    f x@SReturn {} _  = Just x
+    f _ _ = Nothing
+
+-- combine two sequences, attempting pairwise peephole optimizations
+
+pairOpt :: (s -> s -> Maybe s) -> Seq.Seq s -> Seq.Seq s -> Seq.Seq s
+pairOpt peep as bs = f as bs where
+    f as bs | as' Seq.:> a <- Seq.viewr as, b Seq.:< bs' <- Seq.viewl bs = case peep a b of
+        Just ab -> as' `f` Seq.singleton ab `f` bs'
+        Nothing -> as Seq.>< bs
+    f as bs =  as Seq.>< bs
+
+
hunk ./C/Generate.hs 334
-instance Monoid Statement where
-    mempty = SD StatementEmpty empty
-    mappend (SD StatementEmpty _) x = x
-    mappend x (SD StatementEmpty _) = x
-    mappend x@(SD (StatementGoto _) _) (SD (StatementGoto _) _) = x
-    mappend (SD (StatementGoto l) _) y@(SD (StatementLabel l') _) | l == l' = y
---    mappend x y@(SD l@StatementGoto {} _) = combine l x y
---    mappend x@(SD l@StatementLabel {} _) y  = combine l x y
-    mappend a b = combine StatementNoInfo a b
-
-combine l a b = SD l $ do
-    a <- draw a
-    b <- draw b
-    return $ vcat [a,b]
-
hunk ./C/Generate.hs 336
-creturn e = SD (StatementGoto (Name "")) $ text "return " <> draw e <> char ';'
+creturn e = stmt $ SReturn e
hunk ./C/Generate.hs 342
-label n@(Name s) = SD (StatementLabel n) $ text s <> char ':' <+> text "0;"
+label n = stmt $ SLabel n
hunk ./C/Generate.hs 345
-goto n@(Name s) = SD (StatementGoto n) $ text "goto" <+> text s <> char ';'
+goto n = stmt $ SGoto n
+
hunk ./C/Generate.hs 348
---SD $ do
---    us <- mapM (const newUniq) xs
---    let ss = act [ variable (name $ 'v':show u) | u <- us]
---    draw ss
+newVar t = snd `liftM` newDeclVar t
hunk ./C/Generate.hs 350
-newVar t = do
+newDeclVar t = do
hunk ./C/Generate.hs 352
-    return (localVariable t (name $ 'x':show u))
+    let n = name $ 'x':show u
+    return (sd (tell [(n,t)] >> return mempty),localVariable t n)
hunk ./C/Generate.hs 356
---switch :: Expression -> [(Constant,Statement)] -> Maybe Statement -> Statement
hunk ./C/Generate.hs 359
-
-switch' e ts = sd $ text "switch" <+> parens (draw e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where
-    sc (Just x,ss) = do ss <- draw ss ; x <- draw x; return $ text "case" <+> x <> char ':' $$ nest 4 (ss $$ text "break;")
-    sc (Nothing,ss) = do ss <- draw ss; return $ text "default:"  $$  ( nest 4 ss $$ text "break;")
-    md = if any isNothing (fsts ts) then empty else text "default: jhc_case_fell_off(__LINE__);"
+switch' e es = stmt $ SSwitch e es
hunk ./C/Generate.hs 363
-cif exp thn els = sd $ do
-    thn <- draw thn
-    els <- draw els
-    exp <- draw exp
-    return $ text "if" <+> parens exp <+> lbrace <$> nest 4 thn <$> rbrace <+> text "else" <+> lbrace <$> nest 4 els <$> rbrace
+cif exp thn els = stmt $ SIf exp thn els
hunk ./C/Generate.hs 365
-indentBlock sd@(SD si _) = SD si $ do
-    x <- draw sd
-    return $ nest 4 x
+subBlock st = stmt (SBlock st)
hunk ./C/Generate.hs 376
-{-
-creturn_ :: Statement
-withVars :: [Type] -> ([Expression] -> Statement) -> Statement
-
-
-
-
--- functions
-
--- bfunction :: Name -> Type -> [Type] (\[Expression] -> Statement ) -> Function
-
--}
hunk ./C/Generate.hs 392
+travCollect' :: Monoid w => ((a -> Writer w a) -> a -> Writer w a) -> (a -> w) -> a -> w
+travCollect' fn col x = execWriter (f x) where
+    f x = tell (col x) >> fn f x
hunk ./C/Generate.hs 398
-    (body,uv) <- listen (draw (functionBody f))
-    uv' <- flip mapM [ (x,t) | (x,t) <- snubUnder fst uv, x `notElem` fsts (functionArgs f)] $ \ (n,t) -> do
+    cenv <- ask
+    let env = cenv { envUsedLabels = ul } where
+        ul = Set.fromList $ Seq.toList $ Seq.foldMap (travCollect' stmtMapStmt g) stseq
+        St stseq = functionBody f
+        g (SGoto n) = Seq.singleton n
+        g s = mempty
+    (body,uv) <- local (const env) $ listen (draw (functionBody f))
+    uv' <- forM [ (x,t) | (x,t) <- snubUnder fst uv, x `notElem` fsts (functionArgs f)] $ \ (n,t) -> do
hunk ./C/Generate.hs 409
-    fas <- flip mapM (functionArgs f) $ \ (n,t) -> do
+    fas <- forM (functionArgs f) $ \ (n,t) -> do
hunk ./C/Generate.hs 450
-    annotate c s@(SD si _) = SD si ((text "/* " <> text c <> text " */") <$> draw s)
+    --annotate c s@(SD si _) = SD si ((text "/* " <> text c <> text " */") <$> draw s)
+    annotate c s = sd (text "/* " <> text c <> text " */") `mappend` s
hunk ./C/Generate.hs 488
-    ((hd,fns),(_,ass),_written) = runRWS ga () (1,Map.empty)
+    ((hd,fns),(_,ass),_written) = runRWS ga emptyEnv (1,Map.empty)
hunk ./C/Generate.hs 494
-    (anons'',_,_) = runRWS anons' () (1,Map.empty)
+    (anons'',_,_) = runRWS anons' emptyEnv (1,Map.empty)
hunk ./C/Generate.hs 496
-    declStructs ht ss = liftM vsep $ flip mapM ss $ \ (n,ts) -> do
-            ts' <- flip mapM ts $ \ (n,t) -> do
+    declStructs ht ss = liftM vsep $ forM ss $ \ (n,ts) -> do
+            ts' <- forM ts $ \ (n,t) -> do
hunk ./C/Generate.hs 526
-    (fns,_,_) = runRWS ga () (1,Map.empty)
+    (fns,_,_) = runRWS ga emptyEnv (1,Map.empty)
hunk ./data/jhc_rts2.c 146
-// fetch is like a cast, an 'eval' where you know the target is in WHNF
+// both promote and demote evaluate to nothing when debugging is not enabled
+// otherwise, they check that their arguments are in the correct form.
+
hunk ./data/jhc_rts2.c 150
-fetch(sptr_t s)
+promote(sptr_t s)
hunk ./data/jhc_rts2.c 156
+
+static inline sptr_t A_STD A_UNUSED
+demote(wptr_t s)
+{
+        assert(!ISLAZY(s));
+        assert(jhc_valid_whnf(s));
+        return (sptr_t)s;
+}