[switched some primitive representations to use packed strings
John Meacham <john@repetae.net>**20061218104814] hunk ./C/FromGrin.hs 16
+import PackedString
hunk ./C/FromGrin.hs 271
-        return $ cast (basicType r) (functionCall (name n) [ cast (basicType t) v | v <- vs' | t <- as ])
+        return $ cast (basicType r) (functionCall (name $ unpackPS n) [ cast (basicType t) v | v <- vs' | t <- as ])
hunk ./C/Prims.hs 32
-    PrimPrim String          -- Special primitive implemented in the compiler somehow.
+    PrimPrim PackedString          -- Special primitive implemented in the compiler somehow.
hunk ./C/Prims.hs 35
-    | Func { funcIOLike :: Bool, funcName :: String, primArgTypes :: [ExtType], primRetType :: ExtType }   -- function call with C calling convention
+    | Func { funcIOLike :: Bool, funcName :: PackedString, primArgTypes :: [ExtType], primRetType :: ExtType }   -- function call with C calling convention
hunk ./C/Prims.hs 67
+primIsCheap PrimString {} = True
hunk ./C/Prims.hs 82
+primIsConstant PrimString {} = True
hunk ./C/Prims.hs 92
+primEagerSafe PrimString {} = True
hunk ./C/Prims.hs 107
-            s -> Func False s [] emptyExtType
+            s -> Func False (packString s) [] emptyExtType
hunk ./C/Prims.hs 113
-primPrim s = APrim (PrimPrim s) mempty
+primPrim s = APrim (PrimPrim $ packString s) mempty
hunk ./C/Prims.hs 123
-    pprint (PrimPrim t) = text t
+    pprint (PrimPrim t) = text (unpackPS t)
hunk ./C/Prims.hs 126
-    pprint (Func _ s xs r) = parens (text r) <> text s <> tupled (map text xs)
+    pprint (Func _ s xs r) = parens (text r) <> text (unpackPS s) <> tupled (map text xs)
hunk ./C/Prims.hs 140
-    init = PrimDotNet { primStatic = False, primDotNet = DotNetField, primAssembly = packString "", primDotNetName = packString "" }
+    init = PrimDotNet { primIOLike = False, primStatic = False, primDotNet = DotNetField, primAssembly = packString "", primDotNetName = packString "" }
hunk ./E/Demand.hs 22
+import PackedString
hunk ./E/Demand.hs 290
-analyze (EPrim (APrim (PrimPrim "dependingOn") pc) [t1,t2] pt) s = do
+analyze e s | Just (t1,t2,pt) <- from_dependingOn e = do
hunk ./E/Demand.hs 293
-    return (EPrim (APrim (PrimPrim "dependingOn") pc) [t1',t2'] pt,dt1 `glb` dt2)
+    return (EPrim (APrim (PrimPrim $ packString "dependingOn") mempty) [t1',t2'] pt,dt1 `glb` dt2)
hunk ./E/Demand.hs 344
+from_dependingOn (EPrim (APrim (PrimPrim don) _) [t1,t2] pt) | don == packString "dependingOn" = return (t1,t2,pt)
+from_dependingOn _ = fail "not dependingOn"
hunk ./E/FromHs.hs 353
-            prim      = APrim (PrimPrim cn) req
+            prim      = APrim (PrimPrim $ packString cn) req
hunk ./E/FromHs.hs 377
-            prim io rs rtt = EPrim (APrim (Func io rcn (snds rs) rtt) req)
+            prim io rs rtt = EPrim (APrim (Func io (packString rcn) (snds rs) rtt) req)
hunk ./E/PrimOpt.hs 13
+import PackedString
hunk ./E/PrimOpt.hs 142
-processPrimPrim dataTable o@(EPrim (APrim prim _) es orig_t) = maybe o id (primopt prim es (followAliases dataTable orig_t)) where
+processPrimPrim dataTable o@(EPrim (APrim (PrimPrim s) _) es orig_t) = maybe o id (primopt (unpackPS s) es (followAliases dataTable orig_t)) where
hunk ./E/PrimOpt.hs 145
-    primopt (PrimPrim "seq") [x,y] _  = return $ prim_seq x y
-    primopt (PrimPrim "exitFailure__") [w] rt  = return $ EError "" rt
-    primopt (PrimPrim op) [a,b] t | Just cop <- lookup op binOps = mdo
+    primopt "seq" [x,y] _  = return $ prim_seq x y
+    primopt "exitFailure__" [w] rt  = return $ EError "" rt
+    primopt op [a,b] t | Just cop <- lookup op binOps = mdo
hunk ./E/PrimOpt.hs 153
-    primopt (PrimPrim "equalsChar") [a,b] t = return (EPrim (APrim (Operator "==" ["HsChar","HsChar"] "int") mempty) [a,b] t)
-    primopt (PrimPrim "constPeekByte") [a] t = return (EPrim (APrim (Peek "uint8_t") mempty) [a] t)
-    primopt (PrimPrim "box") [a] t = return ans where
+    primopt "equalsChar" [a,b] t = return (EPrim (APrim (Operator "==" ["HsChar","HsChar"] "int") mempty) [a,b] t)
+    primopt "constPeekByte" [a] t = return (EPrim (APrim (Peek "uint8_t") mempty) [a] t)
+    primopt "box" [a] t = return ans where
hunk ./E/PrimOpt.hs 158
-    primopt (PrimPrim "unbox") [a] t = return ans where
+    primopt "unbox" [a] t = return ans where
hunk ./E/PrimOpt.hs 161
-    primopt (PrimPrim op) [a] t | Just o <- lookup op unop = do
+    primopt op [a] t | Just o <- lookup op unop = do
hunk ./E/PrimOpt.hs 168
-    primopt (PrimPrim n) [] t | Just num <- lookup n vs = mdo
+    primopt n [] t | Just num <- lookup n vs = mdo
hunk ./E/PrimOpt.hs 171
-    primopt (PrimPrim pn) [] t | Just c <-  getPrefix "const." pn = mdo
+    primopt pn [] t | Just c <-  getPrefix "const." pn = mdo
hunk ./E/PrimOpt.hs 173
-    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 pn [] _ | Just c <-  getPrefix "error." pn = return (EError c orig_t)
+    primopt "integralCast" [e] t = return $ create_integralCast dataTable e t
+    primopt "integralCast" es t = error $ "Invalid integralCast " ++ show (es,t)
hunk ./E/PrimOpt.hs 177
+processPrimPrim _ e = e
hunk ./E/ToHs.hs 12
+import PackedString
hunk ./E/ToHs.hs 93
-        ans  = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ ["IO ()"])
+        ans  = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ ["IO ()"])
hunk ./E/ToHs.hs 97
-        ans  = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ ["IO " ++ rt])
+        ans  = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ ["IO " ++ rt])
hunk ./E/ToHs.hs 102
-        ans  = text $ "foreign import ccall unsafe \"" ++ fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ [rt])
+        ans  = text $ "foreign import ccall unsafe \"" ++ unpackPS fn ++ "\" " ++ '_':cfuncname furc ++ " :: " ++ concatInter " -> " (map (snd . snd) vals ++ [rt])
hunk ./E/ToHs.hs 279
-transE e@(EPrim (APrim (PrimPrim prim) _) args _) = case (prim,args) of
+transE e@(EPrim (APrim (PrimPrim prim) _) args _) = case (unpackPS prim,args) of
hunk ./E/ToHs.hs 387
-cfuncname Func { funcName = fn, funcIOLike = iol, primArgTypes = as, primRetType = r  } =  text $ ("func_" ++ (if iol then "io" else "pure") ++ "_" ++ fn ++ concatInter "_" (r:as))
+cfuncname Func { funcName = fn, funcIOLike = iol, primArgTypes = as, primRetType = r  } =  text $ ("func_" ++ (if iol then "io" else "pure") ++ "_" ++ unpackPS fn ++ concatInter "_" (r:as))
hunk ./E/Values.hs 9
+import PackedString
hunk ./E/Values.hs 170
-from_unsafeCoerce (EPrim (APrim (PrimPrim "unsafeCoerce") _) [e] t) = return (e,t)
+from_unsafeCoerce (EPrim (APrim (PrimPrim unsafeCoerce) _) [e] t) | unsafeCoerce == packString "unsafeCoerce" = return (e,t)
hunk ./E/Values.hs 178
-unsafeCoerceOpt (EPrim (APrim (PrimPrim "unsafeCoerce") _) [e] t) = f (0::Int) e t where
+unsafeCoerceOpt (EPrim (APrim (PrimPrim uc) _) [e] t) | uc == packString "unsafeCoerce" = f (0::Int) e t where
hunk ./E/Values.hs 220
-isAtomic (EPrim (APrim (PrimPrim "dependingOn") _) [x,y] _) = isAtomic x
+isAtomic (EPrim (APrim (PrimPrim don) _) [x,y] _) | don == packString "dependingOn" = isAtomic x
hunk ./Grin/FromE.hs 16
+import PackedString
hunk ./Grin/FromE.hs 375
-    -- holes - are these still useful?
-    ce (EPrim ap@(APrim (PrimPrim "newHole__") _) [_] _) = do
-        let var = Var v2 (TyPtr TyNode)
-        return $ Store (NodeC (toAtom "@hole") []) :>>= var :-> Return (tuple [var])
-    ce (EPrim ap@(APrim (PrimPrim "fillHole__") _) [r,v,_] _) = do
-        let var = Var v2 TyNode
-            [r',v'] = args [r,v]
-        return $ gEval v' :>>= n1 :-> Update r' n1
hunk ./Grin/FromE.hs 376
-    -- artificial dependencies
-    ce (EPrim ap@(APrim (PrimPrim "newWorld__") _) [_] _) = do
-        return $ Return unit
-    ce (EPrim ap@(APrim (PrimPrim "dependingOn") _) [e,_] _) = ce e
+    ce (EPrim ap@(APrim (PrimPrim prim) _) as _) = f (unpackPS prim) as where
hunk ./Grin/FromE.hs 378
+        -- holes - are these still useful?
+        f "newHole__" [_] = do
+            let var = Var v2 (TyPtr TyNode)
+            return $ Store (NodeC (toAtom "@hole") []) :>>= var :-> Return (tuple [var])
+        f "fillHole__" [r,v,_] = do
+            let var = Var v2 TyNode
+                [r',v'] = args [r,v]
+            return $ gEval v' :>>= n1 :-> Update r' n1
hunk ./Grin/FromE.hs 387
-    -- references
-    ce (EPrim ap@(APrim (PrimPrim "newRef__") _) [v,_] _) = do
-        let [v'] = args [v]
-        return $ Store v'
-    ce (EPrim ap@(APrim (PrimPrim "readRef__") _) [r,_] _) = do
-        let [r'] = args [r]
-        return $ Fetch r'
-    ce (EPrim ap@(APrim (PrimPrim "writeRef__") _) [r,v,_] _) = do
-        let [r',v'] = args [r,v]
-        return $ Update r' v'
+        -- artificial dependencies
+        f "newWorld__" [_] = do
+            return $ Return unit
+        f "dependingOn" [e,_] = ce e
hunk ./Grin/FromE.hs 392
-    -- arrays
-    ce (EPrim ap@(APrim (PrimPrim "newMutArray__") _) [v,def,_] _) = do
-        let [v',def'] = args [v,def]
-        return $ Alloc { expValue = def', expCount = v', expRegion = region_heap, expInfo = mempty }
-    ce (EPrim ap@(APrim (PrimPrim "newBlankMutArray__") _) [v,_] _) = do
-        let [v'] = args [v]
-        return $ Alloc { expValue = ValUnknown (TyPtr TyNode), expCount = v', expRegion = region_heap, expInfo = mempty }
-    ce (EPrim ap@(APrim (PrimPrim "readArray__") _) [r,o,_] _) = do
-        let [r',o'] = args [r,o]
-        return $ Fetch (Index r' o')
-    ce (EPrim ap@(APrim (PrimPrim "indexArray__") _) [r,o] _) = do
-        let [r',o'] = args [r,o]
-        return $ Fetch (Index r' o')
-    ce (EPrim ap@(APrim (PrimPrim "writeArray__") _) [r,o,v,_] _) = do
-        let [r',o',v'] = args [r,o,v]
-        return $ Update (Index r' o') v'
hunk ./Grin/FromE.hs 393
-    ce (EPrim ap@(APrim (PrimPrim ft) _) [v,_] _) | ft `elem` ["unsafeFreezeArray__", "unsafeThawArray__"] = do
-        let [v'] = args [v]
-        return $ Return v'
+        -- references
+        f "newRef__" [v,_] = do
+            let [v'] = args [v]
+            return $ Store v'
+        f "readRef__" [r,_] = do
+            let [r'] = args [r]
+            return $ Fetch r'
+        f "writeRef__" [r,v,_] = do
+            let [r',v'] = args [r,v]
+            return $ Update r' v'
+
+        -- arrays
+        f "newMutArray__" [v,def,_] = do
+            let [v',def'] = args [v,def]
+            return $ Alloc { expValue = def', expCount = v', expRegion = region_heap, expInfo = mempty }
+        f "newBlankMutArray__" [v,_] = do
+            let [v'] = args [v]
+            return $ Alloc { expValue = ValUnknown (TyPtr TyNode), expCount = v', expRegion = region_heap, expInfo = mempty }
+        f "readArray__" [r,o,_] = do
+            let [r',o'] = args [r,o]
+            return $ Fetch (Index r' o')
+        f "indexArray__" [r,o] = do
+            let [r',o'] = args [r,o]
+            return $ Fetch (Index r' o')
+        f "writeArray__" [r,o,v,_] = do
+            let [r',o',v'] = args [r,o,v]
+            return $ Update (Index r' o') v'
+
+        f ft [v,_]  | ft `elem` ["unsafeFreezeArray__", "unsafeThawArray__"] = do
+            let [v'] = args [v]
+            return $ Return v'
hunk ./Grin/FromE.hs 549
-    cc (EPrim (APrim (PrimPrim "dependingOn") _) [e,_] _) = cc e
+    cc (EPrim (APrim (PrimPrim don) _) [e,_] _) | don == packString "dependingOn" = cc e