[create routines to box and unbox primitive types, use them in C.PrimOpt
John Meacham <john@repetae.net>**20061215035900] hunk ./DataConstructors.hs 17
+    extractPrimitive,
+    boxPrimitive,
hunk ./DataConstructors.hs 305
+extractPrimitive :: Monad m => DataTable -> E -> m (E,(ExtType,E))
+extractPrimitive dataTable e = case followAliases dataTable (getType e) of
+    st@(ELit LitCons { litName = c, litArgs = [], litType = t })
+        | t == eHash -> return (e,(show c,st))
+        | otherwise -> do
+            Constructor { conChildren = Just [cn] }  <- getConstructor c dataTable
+            Constructor { conSlots = [st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable
+            let tvra = tVr vn st
+                (vn:_) = newIds (freeIds e)
+            return (eCase e  [Alt (litCons { litName = cn, litArgs = [tvra], litType = (getType e) }) (EVar tvra)] Unknown,(show n,st))
+    e' -> fail $ "extractPrimitive: " ++ show (e,e')
+
+boxPrimitive ::
+    Monad m
+    => DataTable
+    -> E         -- primitive to box
+    -> E         -- what type we want it to have
+    -> m (E,(ExtType,E))
+boxPrimitive dataTable e et = case followAliases dataTable et of
+    st@(ELit LitCons { litName = c, litArgs = [], litType = t })
+        | t == eHash -> return (e,(show c,st))
+        | otherwise -> do
+            Constructor { conChildren = Just [cn] }  <- getConstructor c dataTable
+            Constructor { conSlots = [st@(ELit LitCons { litName = n, litArgs = []})] } <- getConstructor cn dataTable
+            let tvra = tVr vn st
+                (vn:_) = newIds (freeVars (e,et))
+            if isManifestAtomic e then
+                return $ (ELit litCons { litName = cn, litArgs = [e], litType = et },(show n,st))
+             else
+                return $ (eStrictLet tvra e $ ELit litCons { litName = cn, litArgs = [EVar tvra], litType = et },(show n,st))
+    e' -> fail $ "extractPrimitive: " ++ show (e,e')
+
+
hunk ./DataConstructors.hs 636
-primitiveAliases = [(tc_Int__,rt_int),(tc_Addr__,rt_HsPtr),(tc_Char__,rt_HsChar),(tc_Bool__,rt_int)]
+primitiveAliases = [(tc_Int__,rt_int),(tc_Addr__,rt_HsPtr),(tc_Word8__,rt_uint8_t),(tc_Char__,rt_HsChar),(tc_Bool__,rt_int)]
hunk ./E/PrimOpt.hs 8
+import Control.Monad.Fix
hunk ./E/PrimOpt.hs 50
-    (vara:varb:_) = freeNames (freeVars (e,t))
+    (vara:varb:_) = newIds (freeVars (e,t))
hunk ./E/PrimOpt.hs 140
+processPrimPrim :: DataTable -> E -> E
hunk ./E/PrimOpt.hs 146
-    primopt (PrimPrim op) [a,b] t | isJust zz = ans where
-        zz@(~(Just cop)) = lookup op binOps
-        (vara:varb:varc:_) = freeNames (freeVars (a,b,(t,orig_t)))
-        Just (cna,sta,ta) = lookupCType' dataTable t
-        ans = do
-            (_,ta) <- lookupCType dataTable (getType a)
-            (_,tb) <- lookupCType dataTable (getType b)
-            (_,tr) <- lookupCType dataTable t
-            unless (ta == tb && tb == tr) $ fail $ "bad " ++ op
-            return $ unbox dataTable a vara $ \tvra ->
-                unbox dataTable b varb $ \tvrb ->
-                    eStrictLet (tVr varc sta) (EPrim (APrim (Operator cop [ta,ta] ta) mempty) [EVar tvra, EVar tvrb] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = orig_t }))
+    primopt (PrimPrim op) [a,b] t | Just cop <- lookup op binOps = mdo
+        (pa,(ta,sta)) <- extractPrimitive dataTable a
+        (pb,(tb,stb)) <- extractPrimitive dataTable b
+        (bp,(tr,str)) <- boxPrimitive dataTable
+                (EPrim (APrim (Operator cop [ta,ta] tr) mempty) [pa, pb] str) t
+        return bp
hunk ./E/PrimOpt.hs 153
+    primopt (PrimPrim "constPeekByte") [a] t = return (EPrim (APrim (Peek "uint8_t") mempty) [a] t)
hunk ./E/PrimOpt.hs 158
-        (vara:_) = freeNames (freeVars (a,t,orig_t))
+        (vara:_) = newIds (freeVars (a,t,orig_t))
hunk ./E/PrimOpt.hs 160
-    primopt (PrimPrim op) [a] t | op `elem` ["increment","decrement"] = ans where
-        (vara:varc:_) = freeNames (freeVars (a,t,orig_t))
-        Just (cna,sta,ta) = lookupCType' dataTable t
-        ans = do
-            (_,ta) <- lookupCType dataTable (getType a)
-            (_,tr) <- lookupCType dataTable t
-            unless (ta == tr) $ fail $ "bad " ++ op
-            return $ unbox dataTable a vara $ \tvra ->
-                    eStrictLet (tVr varc sta) (EPrim (APrim (Operator (if op == "increment" then "+" else "-") [ta,ta] ta) mempty) [EVar tvra, ELit (LitInt 1 $ rawType ta)] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = orig_t }))
-
-    primopt (PrimPrim n) [] t@(ELit LitCons { litType = h })
-        | good, h == eHash = return $ ELit (LitInt num $ rawType ta)
-        | good = boxedNumber
-        where
-        vs = [("zero",0),("one",1)]
-        good = n `elem` map fst vs
-        Just num = lookup n vs
-        (varc:_) = freeNames (freeVars t)
-        Just (cna,sta,ta) = lookupCType' dataTable t
-        boxedNumber = return (ELit (litCons { litName = cna, litArgs = [ELit (LitInt num $ rawType ta)], litType = t }))
-
-    primopt (PrimPrim pn) [] t | Just c <-  getPrefix "const." pn = do
-        (cn,st,ct) <- case lookupCType' dataTable t of
-            Right x -> return x
-            Left x -> error x
-        let (var:_) = freeNames (freeVars t)
-        return $ eStrictLet (tVr var st) (EPrim (APrim (CConst c ct) mempty) [] st) (ELit (litCons { litName = cn, litArgs = [EVar $ tVr var st], litType = orig_t }))
+    primopt (PrimPrim op) [a] t | Just o <- lookup op unop = do
+        (pa,(ta,sta)) <- extractPrimitive dataTable a
+        let tvra = tVr vn sta; (vn:_) = newIds (freeVars (a,t))
+        (bp,(tr,str)) <- boxPrimitive dataTable (EVar tvra) t
+        let res = EPrim (APrim (Operator o [ta,ta] tr) mempty) [pa, ELit (LitInt 1 sta)] str
+        return $ eStrictLet tvra res bp
+        where unop = [("increment","+"),("decrement","-")]
+    primopt (PrimPrim n) [] t | Just num <- lookup n vs = mdo
+        (res,(_,sta)) <- boxPrimitive dataTable (ELit (LitInt num sta)) t; return res
+        where vs = [("zero",0),("one",1)]
+    primopt (PrimPrim pn) [] t | Just c <-  getPrefix "const." pn = mdo
+        (res,(ta,sta)) <- boxPrimitive dataTable (EPrim (APrim (CConst c ta) mempty) [] sta) t; return res
hunk ./E/PrimOpt.hs 178
--- | Generate an infinite list of names not present in the given set.
-freeNames :: IdSet -> [Id]
-freeNames s  = filter (not . (`member` s)) (genNames (size s))
-
hunk ./E/Values.hs 221
+
+-- | whether a type is "obviously" atomic. fast and lazy, doesn't recurse
+-- True -> definitely atomic
+-- False -> maybe atomic
+isManifestAtomic :: E -> Bool
+isManifestAtomic EVar {}  = True
+isManifestAtomic (ELit LitInt {})  = True
+isManifestAtomic (ELit LitCons { litArgs = []})  = True
+isManifestAtomic _ = False