[generate loops directly for local tail-calls
John Meacham <john@repetae.net>**20060815080646] hunk ./C/FromGrin.hs 31
-newtype C a = C (RWST Todo Requires HcHash Uniq a)
+newtype C a = C (RWST (Todo,Map.Map Atom (Name,[Expression])) Requires HcHash Uniq a)
hunk ./C/FromGrin.hs 37
-runC (C m) =  execUniq1 (runRWST m TodoNothing emptyHcHash)
+runC (C m) =  execUniq1 (runRWST m (TodoNothing,mempty) emptyHcHash)
hunk ./C/FromGrin.hs 106
+    lm <- C $ asks snd
hunk ./C/FromGrin.hs 108
-    return $ (mempty, functionCall (toName (toString a)) vs')
+    case a `Map.lookup` lm of
+        Just (nm,as) -> do
+            let ss = [ a `assign` v | a <- as | v <- vs' ]
+            return (mconcat ss `mappend` goto nm, emptyExpression)
+        Nothing -> return $ (mempty, functionCall (toName (toString a)) vs')
hunk ./C/FromGrin.hs 237
+localJumps xs (C action) = C $ local (\ (x,y) -> (x,Map.fromList xs `mappend` y)) action
+
hunk ./C/FromGrin.hs 248
+convertBody Let { expDefs = defs, expBody = body } = do
+    u <- newUniq
+    nn <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = Tup as :-> _ } -> do
+        vs' <- mapM convertVal as
+        let nm = (toName (show name ++ show u))
+        return (name,(nm,vs'))
+    localJumps nn $ do
+    let done = (toName $ "done" ++ show u)
+    ss <- (convertBody body)
+    rs <- flip mapM defs $ \FuncDef { funcDefName = name, funcDefBody = Tup as :-> b } -> do
+       ss <- convertBody b
+       return (annotate (show as) (label (toName (show name ++ show u))) `mappend` indentBlock ss)
+    return (ss `mappend` goto done `mappend` mconcat (intersperse (goto done) rs) `mappend` label done);
+
hunk ./C/FromGrin.hs 360
-    x <- C ask
+    (x,_) <- C ask
hunk ./C/FromGrin.hs 364
+        TodoExp v | isEmptyExpression er -> return ss
hunk ./C/FromGrin.hs 388
-localTodo todo (C act) = C $ local (const todo) act
+localTodo todo (C act) = C $ local (\ (_,y) -> (todo,y)) act
hunk ./C/Generate.hs 3
-    Function(),
-    Type(),
-    Name(),
-    Expression(),
-    Statement(),
-    FunctionOpts(..),
-    sizeof,
+    anonStructType,
+    assign,
+    basicType,
hunk ./C/Generate.hs 7
+    character,
hunk ./C/Generate.hs 10
-    functionCall,
-    function,
-    dereference,
-    reference,
-    projectAnon,
-    project,
-    project',
-    operator,
-    uoperator,
-    anonStructType,
hunk ./C/Generate.hs 11
-    string,
+    creturn,
+    dereference,
+    Draw(err),
+    drawG,
+    emptyExpression,
hunk ./C/Generate.hs 17
-    switch',
-    number,
-    character,
+    expr,
+    Expression(),
+    expressionRaw,
+    function,
+    Function(),
+    functionCall,
+    FunctionOpts(..),
+    generateC,
+    goto,
+    indentBlock,
hunk ./C/Generate.hs 28
+    label,
+    localVariable,
+    name,
+    Name(),
hunk ./C/Generate.hs 33
-    emptyExpression,
-    drawG,
-    toName,
hunk ./C/Generate.hs 34
-    expr,
-    name,
-    variable,
-    localVariable,
-    creturn,
-    Draw(err),
-    basicType,
-    withVars,
+    number,
+    operator,
+    project,
+    project',
+    projectAnon,
hunk ./C/Generate.hs 40
-    voidStarType,
-    structAnon,
-    structType,
-    assign,
-    label,
-    goto,
+    reference,
hunk ./C/Generate.hs 42
-    generateC,
-    expressionRaw,
+    sizeof,
+    Statement(),
hunk ./C/Generate.hs 45
+    string,
+    structAnon,
+    structType,
+    switch',
+    toName,
+    Type(),
+    uoperator,
+    variable,
+    voidStarType,
hunk ./C/Generate.hs 55
+    withVars,
hunk ./C/Generate.hs 83
+data StatementInfo = StatementGoto Name | StatementLabel Name | StatementNoInfo | StatementEmpty
+
hunk ./C/Generate.hs 87
-newtype Statement = SD (G Doc)
+data Statement = SD StatementInfo (G Doc)
hunk ./C/Generate.hs 90
+sd = SD StatementNoInfo
+
hunk ./C/Generate.hs 107
-    draw (SD g) = g
-    err s = SD $ terr s
+    draw (SD _ g) = g
+    err s = sd $ terr s
hunk ./C/Generate.hs 188
-statementRaw s = SD (text s)
+statementRaw s = sd (text s)
hunk ./C/Generate.hs 247
-expr e = SD $ draw e <> char ';'
+expr e = sd $ draw e <> char ';'
hunk ./C/Generate.hs 250
-    mempty = SD empty
-    mconcat = statements
-    mappend a b = mconcat [a,b]
+    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 265
-statements ss = SD $ do
-    ss <- mapM draw ss
-    return $ vcat ss -- foldl ($+$) empty ss
+statements = mconcat
hunk ./C/Generate.hs 268
-creturn e = SD $ text "return " <> draw e <> char ';'
+creturn e = SD (StatementGoto (Name "")) $ text "return " <> draw e <> char ';'
hunk ./C/Generate.hs 274
-label (Name s) = SD $ text s <> char ':'
+label n@(Name s) = SD (StatementLabel n) $ text s <> char ':'
hunk ./C/Generate.hs 277
-goto (Name s) = SD $ text "goto" <+> text s <> char ';'
+goto n@(Name s) = SD (StatementGoto n) $ text "goto" <+> text s <> char ';'
hunk ./C/Generate.hs 295
-switch' e ts = SD $ text "switch" <+> parens (draw e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where
+switch' e ts = sd $ text "switch" <+> parens (draw e) <+> char '{' <$> vcat (map sc ts) <$> md <$>  char '}' where
hunk ./C/Generate.hs 302
-cif exp thn els = SD $ do
+cif exp thn els = sd $ do
hunk ./C/Generate.hs 308
+indentBlock sd@(SD si _) = SD si $ do
+    x <- draw sd
+    return $ nest 4 x
hunk ./C/Generate.hs 390
-    annotate c s = SD ((text "/* " <> text c <> text " */") <$> draw s)
+    annotate c s@(SD si _) = SD si ((text "/* " <> text c <> text " */") <$> draw s)
hunk ./Grin/Simplify.hs 361
-    f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars e `Set.intersect` (Set.fromList $ map funcDefName defs)) = do
-        mtick "Optimize.optimize.let-shrink-head"
-        f (e :>>= l :-> lt { expDefs = defs, expBody = r })
+--    f lt@Let { expDefs = defs, expBody = e :>>= l :-> r } | Set.null (freeVars e `Set.intersect` (Set.fromList $ map funcDefName defs)) = do
+--        mtick "Optimize.optimize.let-shrink-head"
+--        f (e :>>= l :-> lt { expDefs = defs, expBody = r })