[add support for manipulating unboxed numerical values directly in haskell source code
John Meacham <john@repetae.net>**20061115014257] hunk ./DataConstructors.hs 6
+    primitiveAliases,
hunk ./DataConstructors.hs 73
+tipe' (TCon (Tycon n k)) | Just n' <- lookup n primitiveAliases = return $ ELit litCons { litName = n', litType = kind k }
hunk ./DataConstructors.hs 389
-    newDataTable = DataTable (Map.mapWithKey fixupMap $ Map.fromList [ (conName x,procNewTypes x) | x <- ds' ])
+    newDataTable = DataTable (Map.mapWithKey fixupMap $ Map.fromList [ (conName x,procNewTypes x) | x <- ds', conName x `notElem` map fst primitiveAliases ])
hunk ./DataConstructors.hs 598
+primitiveAliases = [(tc_Int__,rt_int),(tc_Addr__,rt_HsPtr)]
hunk ./E/FromHs.hs 90
+    f (TCon (Tycon n k)) | Just n' <- lookup n primitiveAliases = ELit litCons { litName = n', litType = kind k }
hunk ./E/PrimOpt.hs 8
+import Maybe
hunk ./E/PrimOpt.hs 139
-processPrimPrim dataTable o@(EPrim (APrim prim _) es t) = case primopt prim es t of
-            Just e -> e
-            Nothing -> o
-        where
-        primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
-        primopt (PrimPrim "exitFailure__") [w] rt  = return $ EError "" rt
---        primopt (PrimPrim "newRef__") [x,y] rt  = return $ EAp (EAp (ELam x' $ ELam y' $ eCaseTup' (EPrim (primPrim "newRef_") [EVar x',EVar y'] (ltTuple' [a,b])) [a',b'] (eTuple [EVar a',EVar b']) ) x) y where
---            [x',y',a',b'] = vars [getType x,getType y,a,b]
---            ELit LitCons { litArgs = [a,b], litType = ESort EStar } = rt
---        primopt (PrimPrim "readRef__") [x,y] rt  = return $ EAp (EAp (ELam x' $ ELam y' $ eCaseTup' (EPrim (primPrim "readRef_") [EVar x',EVar y'] (ltTuple' [a,b])) [a',b'] (eTuple [EVar a',EVar b']) ) x) y where
---            [x',y',a',b'] = vars [getType x,getType y,a,b]
---            ELit LitCons { litArgs = [a,b], litType = ESort EStar } = rt
---        primopt (PrimPrim "newHole__") [y] (ELit LitCons { litName = name, litArgs = [b], litType = ESort EStar }) | tc_IOResult =
---            return $ eCaseTup' (EPrim (primPrim "newHole_") [y] (ltTuple' [tWorld__,b])) [a',b'] (eJustIO (EVar a') (EVar b')) where
---                (a':b':_) = vars [tWorld__,b,y]
-
-        primopt (PrimPrim "divide") [a,b] t = ans where
-            (vara:varb:varc:_) = freeNames (freeVars (a,b,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 divide"
-                return $ unbox dataTable a vara $ \tvra ->
-                    unbox dataTable b varb $ \tvrb ->
-                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "/" [ta,ta] ta) mempty) [EVar tvra, EVar tvrb] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = t }))
-        primopt (PrimPrim "plus") [a,b] t = ans where
-            (vara:varb:varc:_) = freeNames (freeVars (a,b,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 plus"
-                return $ unbox dataTable a vara $ \tvra ->
-                    unbox dataTable b varb $ \tvrb ->
-                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "+" [ta,ta] ta) mempty) [EVar tvra, EVar tvrb] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = t }))
-        primopt (PrimPrim "minus") [a,b] t = ans where
-            (vara:varb:varc:_) = freeNames (freeVars (a,b,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 minus"
-                return $ unbox dataTable a vara $ \tvra ->
-                    unbox dataTable b varb $ \tvrb ->
-                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "-" [ta,ta] ta) mempty) [EVar tvra, EVar tvrb] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = t }))
-        primopt (PrimPrim "times") [a,b] t = ans where
-            (vara:varb:varc:_) = freeNames (freeVars (a,b,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 minus"
-                return $ unbox dataTable a vara $ \tvra ->
-                    unbox dataTable b varb $ \tvrb ->
-                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "*" [ta,ta] ta) mempty) [EVar tvra, EVar tvrb] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = t }))
-        primopt (PrimPrim "modulus") [a,b] t = ans where
-            (vara:varb:varc:_) = freeNames (freeVars (a,b,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 minus"
-                return $ unbox dataTable a vara $ \tvra ->
-                    unbox dataTable b varb $ \tvrb ->
-                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "%" [ta,ta] ta) mempty) [EVar tvra, EVar tvrb] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = t }))
+processPrimPrim dataTable o@(EPrim (APrim prim _) es orig_t) = maybe o id (primopt prim es (followAliases dataTable orig_t)) where
+    binOps = [("divide","/"),("plus","+"),("minus","-"),("times","*"),("modulus","%")]
hunk ./E/PrimOpt.hs 142
-        primopt (PrimPrim "increment") [a] t = ans where
-            (vara:varc:_) = freeNames (freeVars (a,t))
-            Just (cna,sta,ta) = lookupCType' dataTable t
-            ans = do
-                (_,ta) <- lookupCType dataTable (getType a)
-                (_,tr) <- lookupCType dataTable t
-                unless (ta == tr) $ fail "bad increment"
-                return $ unbox dataTable a vara $ \tvra ->
-                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "+" [ta,ta] ta) mempty) [EVar tvra, ELit (LitInt 1 $ rawType ta)] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = t }))
+    primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
+    primopt (PrimPrim "exitFailure__") [w] rt  = return $ EError "" rt
+    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 "box") [a] t = return ans where
+        Just (cna,sta,ta) = lookupCType' dataTable t
+        ans = ELit litCons { litName = cna, litArgs = [a], litType = orig_t }
+    primopt (PrimPrim "unbox") [a] t = return ans where
+        (vara:_) = freeNames (freeVars (a,t,orig_t))
+        ans = unbox dataTable a vara $ \tvra -> EVar tvra
+    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 }))
hunk ./E/PrimOpt.hs 172
-        primopt (PrimPrim "decrement") [a] t = ans where
-            (vara:varc:_) = freeNames (freeVars (a,t))
-            Just (cna,sta,ta) = lookupCType' dataTable t
-            ans = do
-                (_,ta) <- lookupCType dataTable (getType a)
-                (_,tr) <- lookupCType dataTable t
-                unless (ta == tr) $ fail "bad decrement"
-                return $ unbox dataTable a vara $ \tvra ->
-                        eStrictLet (tVr varc sta) (EPrim (APrim (Operator "-" [ta,ta] ta) mempty) [EVar tvra, ELit (LitInt 1 $ rawType ta)] sta) (ELit (litCons { litName = cna, litArgs = [EVar (tVr varc sta)], litType = t }))
-
-        primopt (PrimPrim "zero") [] t = ans where
-            (varc:_) = freeNames (freeVars t)
-            Just (cna,sta,ta) = lookupCType' dataTable t
-            ans = return (ELit (litCons { litName = cna, litArgs = [ELit (LitInt 0 $ rawType ta)], litType = t }))
-        primopt (PrimPrim "one") [] t = ans where
-            (varc:_) = freeNames (freeVars t)
-            Just (cna,sta,ta) = lookupCType' dataTable t
-            ans = return (ELit (litCons { litName = cna, litArgs = [ELit (LitInt 1 $ rawType ta)], litType = 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 }))
hunk ./E/PrimOpt.hs 183
-        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 = t }))
-        primopt (PrimPrim pn) [] t | Just c <-  getPrefix "error." pn = return (EError c t)
-        primopt (PrimPrim "integralCast") [e] t = return $ create_integralCast dataTable e t
-        primopt (PrimPrim "integralCast") es t = error $ "Invalid integralCast " ++ show (es,t)
-        primopt _ _ _ = fail "not a primopt we care about"
+    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 pn) [] _ | Just c <-  getPrefix "error." pn = return (EError c orig_t)
+    primopt (PrimPrim "integralCast") [e] t = return $ create_integralCast dataTable e t
+    primopt (PrimPrim "integralCast") es t = error $ "Invalid integralCast " ++ show (es,t)
+    primopt _ _ _ = fail "not a primopt we care about"
hunk ./Name/Names.hs 79
+tc_Int__ = toName TypeConstructor  ("Jhc.Prim","Int__")
+tc_Addr__ = toName TypeConstructor  ("Jhc.Prim","Addr__")
+
hunk ./lib/base/Jhc/Int.hs 4
-module Jhc.Int(Int(),increment,decrement,plus,minus,times,divide,modulus,zero,one) where
+module Jhc.Int(Int(),Int__(),increment,decrement,plus,minus,times,divide,modulus,zero,one,boxInt,unboxInt) where
hunk ./lib/base/Jhc/Int.hs 7
+import Jhc.Prim(Int__())
hunk ./lib/base/Jhc/Int.hs 19
+foreign import primitive "box" boxInt :: Int__ -> Int
+foreign import primitive "unbox" unboxInt :: Int -> Int__
+
hunk ./lib/base/Jhc/Prim.hs 4
+    Int__(),
+    Addr__(),
hunk ./lib/base/Jhc/Prim.hs 15
+data Int__ :: #
+data Addr__ :: #
+