[major code cleanups in HsSyn -> E conversion
John Meacham <john@repetae.net>**20051003011124] hunk ./E/LetFloat.hs 36
+doLetRec stats ds _ | hasRepeatUnder fst ds = error "doLetRec: repeated variables!"
hunk ./E/Values.hs 34
+unboxedTuple es =  LitCons (unboxedNameTuple DataConstructor (length es)) es (ltTuple' ts) where
+    ts = map getType es
hunk ./E/Values.hs 109
-
+-- | strict version of let, evaluates argument before assigning it.
+eStrictLet t@(TVr { tvrType =  ty }) v e | sortStarLike ty && isAtomic v = subst t v e
+eStrictLet t v e = ECase v t [] (Just e)
hunk ./E/Values.hs 125
-eStrictLet t@(TVr { tvrType =  ty }) v e | sortStarLike ty && isAtomic v = subst t v e
-eStrictLet t v e = ECase v t [] (Just e)
hunk ./Main.hs 142
-    --mapM_ print [ (EVar t) | (t,_) <- (Map.elems (hoEs ho))]
-
+    -- some useful values
hunk ./Main.hs 144
-
-    let isExported n | "Instance@" `isPrefixOf` show n = True
+        isExported n | "Instance@" `isPrefixOf` show n = True
hunk ./Main.hs 147
-    let decls = concat [ hsModuleDecls  m | (_,m) <- tiDataModules tiData ] ++ Map.elems (tiDataLiftedInstances tiData)
+        decls = concat [ hsModuleDecls  m | (_,m) <- tiDataModules tiData ] ++ Map.elems (tiDataLiftedInstances tiData)
+
+    -- build datatables
hunk ./Main.hs 151
-    let fullDataTable =  (dataTable `mappend` hoDataTable ho)
+    let fullDataTable = (dataTable `mappend` hoDataTable ho)
+    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)
+
+    -- Convert Haskell decls to E
hunk ./Main.hs 157
-    wdump FD.Progress $ do
-        putErrLn $ show (length ds) ++ " declarations converted."
+
+    -- Build rules
hunk ./Main.hs 161
-    wdump FD.Datatable $ putErrLn (render $ showDataTable dataTable)
+
+    -- some more useful values including reachable names
hunk ./Main.hs 165
-    let doopt' = doopt mangle
+    let reached = Set.fromList [ tvrNum b | (_,b,_) <- reachable graph  [ tvrNum b | (n,b,_) <- ds, isExported n]]
+        graph =  (newGraph ds (\ (_,b,_) -> tvrNum b) (\ (_,_,c) -> freeVars c))
+        (_,dog)  = findLoopBreakers (const 0) graph
+
+    -- This is the main function that processes the E's before passing them into the ho file.
hunk ./Main.hs 172
-        let g (TVr { tvrIdent = 0 }) = error "absurded zero"
-            g tvr@(TVr { tvrIdent = n, tvrType = k})
-                | sortStarLike k =  tAbsurd k
-                | otherwise = EVar tvr
+        lc <- postProcessE stats n inscope fullDataTable lc
hunk ./Main.hs 175
-        fvs <- return $ foldr IM.delete (freeVars lc)  inscope
-        when (IM.size fvs > 0) $ do
-            putDocM putErr $ parens $ text "Absurded vars:" <+> align (hsep $ map pprint (IM.elems fvs))
hunk ./Main.hs 176
-        lc <- mangle False ("Absurdize") (return . substMap (IM.map g fvs)) lc
-        lc <- mangle False ("Barendregt: " ++ show n) (return . barendregt) lc
-        lc <- mangle False "deNewtype" (return . deNewtype fullDataTable) lc
-        lc <- doopt' False stats "FixupLets..." (\stats x -> atomizeApps stats x >>= coalesceLets stats)  lc
hunk ./Main.hs 182
-        lc <- doopt' False stats "Float Inward..." (\stats x -> return (floatInward allRules x))  lc
-        lc <- doopt' False stats "SuperSimplify" cm lc
+        lc <- doopt mangle False stats "Float Inward..." (\stats x -> return (floatInward allRules x))  lc
+        lc <- doopt mangle False stats "SuperSimplify" cm lc
hunk ./Main.hs 187
-        nfo <- return $ if isExported n then Info.insert Exported nfo else nfo
+        nfo <- return $ if isExported n then setProperty prop_EXPORTED nfo else nfo
hunk ./Main.hs 190
-    let reached = Set.fromList [ tvrNum b | (_,b,_) <- reachable graph  [ tvrNum b | (n,b,_) <- ds, isExported n]]
-        graph =  (newGraph ds (\ (_,b,_) -> tvrNum b) (\ (_,_,c) -> freeVars c))
-        (_,dog)  = findLoopBreakers (const 0) graph
hunk ./Main.hs 196
-    let ds' = reachable (newGraph ds (\ (_,b,_) -> tvrNum b) (\ (_,_,c) -> freeVars c)) [ tvrNum b | (n,b,_) <- ds, isExported n]
-    wdump FD.Progress $ putErrLn $ "Functions culled: " ++ show (length ds - length ds')
+    let ds' = reachable (newGraph ds (\ (_,b,_) -> tvrNum b) (\ (_,_,c) -> freeVars c)) [ tvrNum b | (n,b,_) <- ds, getProperty prop_EXPORTED b]
hunk ./Main.hs 199
+
+-- | take E directly generated from haskell source and bring it into line with
+-- expected invarients. this only needs be done once.  it replaces all
+-- ambiguous types with the absurd one, gets rid of all newtypes, does a basic
+-- renaming pass, and makes sure applications are only to atomic variables.
+
+postProcessE :: Stats.Stats -> Name -> [Id] -> DataTable -> E -> IO E
+postProcessE stats n inscope dataTable lc = do
+    let g (TVr { tvrIdent = 0 }) = error "absurded zero"
+        g tvr@(TVr { tvrIdent = n, tvrType = k})
+            | sortStarLike k =  tAbsurd k
+            | otherwise = EVar tvr
+    fvs <- return $ foldr IM.delete (freeVars lc)  inscope
+    when (IM.size fvs > 0 && dump FD.Progress) $ do
+        putDocM putErr $ parens $ text "Absurded vars:" <+> align (hsep $ map pprint (IM.elems fvs))
+    let mangle = mangle' (Just $ Set.fromList $ inscope) dataTable
+    lc <- mangle False ("Absurdize") (return . substMap (IM.map g fvs)) lc
+    lc <- mangle False "deNewtype" (return . deNewtype dataTable) lc
+    lc <- mangle False ("Barendregt: " ++ show n) (return . barendregt) lc
+    lc <- doopt mangle False stats "FixupLets..." (\stats x -> atomizeApps stats x >>= coalesceLets stats)  lc
+    return lc
hunk ./Main.hs 221
+getExports ho =  Set.fromList $ map toId $ concat $  Map.elems (hoExports ho)
+shouldBeExported exports tvr =  tvrIdent tvr `Set.member` exports || getProperty prop_INSTANCE tvr || getProperty prop_SRCLOC_ANNOTATE_FUN tvr
hunk ./Main.hs 282
-    (lc,_) <- return $ E.CPR.cprAnalyze mempty lc
-    sequence_ [ putStrLn $ (tvrShowName t) <+> show (maybe E.CPR.Top id (Info.lookup (tvrInfo t)) ::  E.CPR.Val) | (t,_,_) <- scCombinators $ eToSC dataTable lc ]
+    --(lc@(ELetRec defs v),_) <- return $ E.CPR.cprAnalyze mempty lc
+    --lc <- return $ ELetRec (concatMap (uncurry $ workWrap dataTable) ds) v
+    --flip mapM_ defs $ \ (t,e) -> do
+    --    let xs = workWrap dataTable t e
+    --    when (length xs > 1) $ do
+    --        putStrLn (prettyE (ELetRec xs Unknown))
+    --sequence_ [ putStrLn $ (tvrShowName t) <+> show (maybe E.CPR.Top id (Info.lookup (tvrInfo t)) ::  E.CPR.Val) | (t,_,_) <- scCombinators $ eToSC dataTable lc ]