127 | | assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) |
128 | | = let |
129 | | -- pass 1: collect up the offsets of the local labels. |
130 | | -- Remember that the first insn starts at offset |
131 | | -- sizeOf Word / sizeOf Word16 |
132 | | -- since offset 0 (eventually) will hold the total # of insns. |
133 | | lableInitialOffset |
134 | | | wORD_SIZE_IN_BITS == 64 = 4 |
135 | | | wORD_SIZE_IN_BITS == 32 = 2 |
136 | | | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" |
137 | | label_env = mkLabelEnv Map.empty lableInitialOffset instrs |
138 | | |
139 | | -- Jump instructions are variable-sized, there are long and |
140 | | -- short variants depending on the magnitude of the offset. |
141 | | -- However, we can't tell what size instructions we will need |
142 | | -- until we have calculated the offsets of the labels, which |
143 | | -- depends on the size of the instructions... We could |
144 | | -- repeat the calculation and hope to reach a fixpoint, but |
145 | | -- instead we just calculate the worst-case size and use that |
146 | | -- to decide whether *all* the jumps in this BCO will be long |
147 | | -- or short. |
148 | | |
149 | | -- True => all our jumps will be long |
150 | | large_bco = isLarge max_w16s |
151 | | where max_w16s = fromIntegral (length instrs) * maxInstr16s :: Word |
152 | | |
153 | | mkLabelEnv :: Map Word16 Word -> Word -> [BCInstr] |
154 | | -> Map Word16 Word |
155 | | mkLabelEnv env _ [] = env |
156 | | mkLabelEnv env i_offset (i:is) |
157 | | = let new_env |
158 | | = case i of LABEL n -> Map.insert n i_offset env ; _ -> env |
159 | | in mkLabelEnv new_env (i_offset + instrSize16s i large_bco) is |
160 | | |
161 | | findLabel :: Word16 -> Word |
162 | | findLabel lab |
163 | | = case Map.lookup lab label_env of |
164 | | Just bco_offset -> bco_offset |
165 | | Nothing -> pprPanic "assembleBCO.findLabel" (ppr lab) |
166 | | in |
167 | | do -- pass 2: generate the instruction, ptr and nonptr bits |
168 | | insns <- return emptySS :: IO (SizedSeq Word16) |
169 | | lits <- return emptySS :: IO (SizedSeq BCONPtr) |
170 | | ptrs <- return emptySS :: IO (SizedSeq BCOPtr) |
171 | | let init_asm_state = (insns,lits,ptrs) |
172 | | (final_insns, final_lits, final_ptrs) |
173 | | <- mkBits dflags large_bco findLabel init_asm_state instrs |
174 | | |
175 | | let asm_insns = ssElts final_insns |
176 | | n_insns = sizeSS final_insns |
177 | | |
178 | | insns_arr = mkInstrArray lableInitialOffset n_insns asm_insns |
179 | | !insns_barr = case insns_arr of UArray _lo _hi _n barr -> barr |
180 | | |
181 | | bitmap_arr = mkBitmapArray bsize bitmap |
182 | | !bitmap_barr = case bitmap_arr of UArray _lo _hi _n barr -> barr |
183 | | |
184 | | let ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs |
185 | | |
186 | | -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive |
187 | | -- objects, since they might get run too early. Disable this until |
188 | | -- we figure out what to do. |
189 | | -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) |
190 | | |
191 | | return ul_bco |
192 | | -- where |
193 | | -- zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) |
194 | | -- free ptr |
| 128 | assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = do |
| 129 | -- pass 1: collect up the offsets of the local labels. |
| 130 | let asm = mapM_ (assembleI dflags) instrs |
| 131 | |
| 132 | -- Remember that the first insn starts at offset |
| 133 | -- sizeOf Word / sizeOf Word16 |
| 134 | -- since offset 0 (eventually) will hold the total # of insns. |
| 135 | initial_offset = largeArg16s |
| 136 | |
| 137 | -- Jump instructions are variable-sized, there are long and short variants |
| 138 | -- depending on the magnitude of the offset. However, we can't tell what |
| 139 | -- size instructions we will need until we have calculated the offsets of |
| 140 | -- the labels, which depends on the size of the instructions... So we |
| 141 | -- first create the label environment assuming that all jumps are short, |
| 142 | -- and if the final size is indeed small enough for short jumps, we are |
| 143 | -- done. Otherwise, we repeat the calculation, and we force all jumps in |
| 144 | -- this BCO to be long. |
| 145 | (n_insns0, lbl_map0) = inspectAsm False initial_offset asm |
| 146 | ((n_insns, lbl_map), long_jumps) |
| 147 | | isLarge n_insns0 = (inspectAsm True initial_offset asm, True) |
| 148 | | otherwise = ((n_insns0, lbl_map0), False) |
| 149 | |
| 150 | findLabel :: Word16 -> Word |
| 151 | findLabel lbl = fromMaybe |
| 152 | (pprPanic "assembleBCO.findLabel" (ppr lbl)) |
| 153 | (Map.lookup lbl lbl_map) |
| 154 | |
| 155 | env :: Word16 -> Operand |
| 156 | env |
| 157 | | long_jumps = LargeOp . findLabel |
| 158 | | otherwise = SmallOp . fromIntegral . findLabel |
| 159 | |
| 160 | -- pass 2: run assembler and generate instructions, literals and pointers |
| 161 | let initial_insns = addListToSS emptySS $ largeArg n_insns |
| 162 | let initial_state = (initial_insns, emptySS, emptySS) |
| 163 | (final_insns, final_lits, final_ptrs) <- execState initial_state $ runAsm env asm |
| 164 | |
| 165 | -- precomputed size should be equal to final size |
| 166 | ASSERT (n_insns == sizeSS final_insns) return () |
| 167 | |
| 168 | let asm_insns = ssElts final_insns |
| 169 | barr a = case a of UArray _lo _hi _n b -> b |
| 170 | |
| 171 | insns_arr = listArray (0, n_insns - 1) asm_insns |
| 172 | !insns_barr = barr insns_arr |
| 173 | |
| 174 | bitmap_arr = mkBitmapArray bsize bitmap |
| 175 | !bitmap_barr = barr bitmap_arr |
| 176 | |
| 177 | ul_bco = UnlinkedBCO nm arity insns_barr bitmap_barr final_lits final_ptrs |
| 178 | |
| 179 | -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive |
| 180 | -- objects, since they might get run too early. Disable this until |
| 181 | -- we figure out what to do. |
| 182 | -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) |
| 183 | |
| 184 | return ul_bco |
227 | | sizeSS16 :: SizedSeq a -> Word16 |
228 | | sizeSS16 (SizedSeq n _) = fromIntegral n |
| 212 | data Operand |
| 213 | = Op Word |
| 214 | | SmallOp Word16 |
| 215 | | LargeOp Word |
| 216 | | LabelOp Word16 |
| 217 | |
| 218 | data Assembler a |
| 219 | = AllocPtr (IO BCOPtr) (Word16 -> Assembler a) |
| 220 | | AllocLit [BCONPtr] (Word16 -> Assembler a) |
| 221 | | AllocLabel Word16 (Assembler a) |
| 222 | | Emit Word16 [Operand] (Assembler a) |
| 223 | | NullAsm a |
| 224 | |
| 225 | instance Monad Assembler where |
| 226 | return = NullAsm |
| 227 | NullAsm x >>= f = f x |
| 228 | AllocPtr p k >>= f = AllocPtr p (k >=> f) |
| 229 | AllocLit l k >>= f = AllocLit l (k >=> f) |
| 230 | AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f) |
| 231 | Emit w ops k >>= f = Emit w ops (k >>= f) |
| 232 | |
| 233 | ioptr :: IO BCOPtr -> Assembler Word16 |
| 234 | ioptr p = AllocPtr p return |
| 235 | |
| 236 | ptr :: BCOPtr -> Assembler Word16 |
| 237 | ptr = ioptr . return |
| 238 | |
| 239 | lit :: [BCONPtr] -> Assembler Word16 |
| 240 | lit l = AllocLit l return |
| 241 | |
| 242 | label :: Word16 -> Assembler () |
| 243 | label w = AllocLabel w (return ()) |
| 244 | |
| 245 | emit :: Word16 -> [Operand] -> Assembler () |
| 246 | emit w ops = Emit w ops (return ()) |
| 247 | |
| 248 | type LabelEnv = Word16 -> Operand |
| 249 | |
| 250 | runAsm :: LabelEnv -> Assembler a -> State AsmState IO a |
| 251 | runAsm _ (NullAsm x) = return x |
| 252 | runAsm e (AllocPtr p_io k) = do |
| 253 | p <- lift p_io |
| 254 | w <- State $ \(st_i0,st_l0,st_p0) -> do |
| 255 | let st_p1 = addToSS st_p0 p |
| 256 | return ((st_i0,st_l0,st_p1), sizeSS16 st_p0) |
| 257 | runAsm e $ k w |
| 258 | runAsm e (AllocLit lits k) = do |
| 259 | w <- State $ \(st_i0,st_l0,st_p0) -> do |
| 260 | let st_l1 = addListToSS st_l0 lits |
| 261 | return ((st_i0,st_l1,st_p0), sizeSS16 st_l0) |
| 262 | runAsm e $ k w |
| 263 | runAsm e (AllocLabel _ k) = runAsm e k |
| 264 | runAsm e (Emit w ops k) = do |
| 265 | let (large, words) = expand False ops [] |
| 266 | opcode |
| 267 | | large = largeArgInstr w |
| 268 | | otherwise = w |
| 269 | expand l [] r_ws = (l, reverse r_ws) |
| 270 | expand l (op : ops) r_ws = case op of |
| 271 | SmallOp w -> expand l ops (w : r_ws) |
| 272 | LargeOp w -> expand True ops (reverse (largeArg w) ++ r_ws) |
| 273 | LabelOp lbl -> expand l (e lbl : ops) r_ws |
| 274 | Op w |
| 275 | | l || isLarge w -> expand l (LargeOp w : ops) r_ws |
| 276 | | otherwise -> expand l (SmallOp (fromIntegral w) : ops) r_ws |
| 277 | State $ \(st_i0,st_l0,st_p0) -> do |
| 278 | let st_i1 = addListToSS st_i0 (opcode : words) |
| 279 | return ((st_i1,st_l0,st_p0), ()) |
| 280 | runAsm e k |
| 281 | |
| 282 | type LabelEnvMap = Map Word16 Word |
| 283 | |
| 284 | data InspectState = InspectState |
| 285 | { instrCount :: !Word |
| 286 | , ptrCount :: !Word |
| 287 | , litCount :: !Word |
| 288 | , lblEnv :: LabelEnvMap |
| 289 | } |
| 290 | |
| 291 | inspectAsm :: Bool -> Word -> Assembler a -> (Word, LabelEnvMap) |
| 292 | inspectAsm long_jumps initial_offset |
| 293 | = go (InspectState initial_offset 0 0 Map.empty) |
| 294 | where |
| 295 | go s (NullAsm _) = (instrCount s, lblEnv s) |
| 296 | go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n) |
| 297 | where n = ptrCount s |
| 298 | go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n) |
| 299 | where n = litCount s |
| 300 | go s (AllocLabel lbl k) = go s' k |
| 301 | where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) } |
| 302 | go s (Emit _ ops k) = go s' k |
| 303 | where |
| 304 | s' = s { instrCount = instrCount s + size } |
| 305 | size = count False ops 0 + 1 |
| 306 | count _ [] n = n |
| 307 | count l (op : ops) n |
| 308 | | is_large = count True ops (n + largeArg16s) |
| 309 | | otherwise = count l ops (n + 1) |
| 310 | where |
| 311 | is_large = case op of |
| 312 | SmallOp _ -> False |
| 313 | LabelOp _ |
| 314 | | long_jumps -> True |
| 315 | | otherwise -> False |
| 316 | LargeOp _ -> True |
| 317 | Op n |
| 318 | | l || isLarge n -> True |
| 319 | | otherwise -> False |
| 320 | |
252 | | -- This is where all the action is (pass 2 of the assembler) |
253 | | mkBits :: DynFlags |
254 | | -> Bool -- jumps are long |
255 | | -> (Word16 -> Word) -- label finder |
256 | | -> AsmState |
257 | | -> [BCInstr] -- instructions (in) |
258 | | -> IO AsmState |
259 | | |
260 | | mkBits dflags long_jumps findLabel st proto_insns |
261 | | = foldM doInstr st proto_insns |
262 | | where |
263 | | doInstr :: AsmState -> BCInstr -> IO AsmState |
264 | | doInstr st i |
265 | | = case i of |
266 | | STKCHECK n |
267 | | | isLarge n -> instrn st (largeArgInstr bci_STKCHECK : largeArg n) |
268 | | | otherwise -> instr2 st bci_STKCHECK (fromIntegral n) |
269 | | |
270 | | PUSH_L o1 -> instr2 st bci_PUSH_L o1 |
271 | | PUSH_LL o1 o2 -> instr3 st bci_PUSH_LL o1 o2 |
272 | | PUSH_LLL o1 o2 o3 -> instr4 st bci_PUSH_LLL o1 o2 o3 |
273 | | PUSH_G nm -> do (p, st2) <- ptr st (BCOPtrName nm) |
274 | | instr2 st2 bci_PUSH_G p |
275 | | PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op) |
276 | | instr2 st2 bci_PUSH_G p |
277 | | PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto |
278 | | (p, st2) <- ptr st (BCOPtrBCO ul_bco) |
279 | | instr2 st2 bci_PUSH_G p |
280 | | PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto |
281 | | (p, st2) <- ptr st (BCOPtrBCO ul_bco) |
282 | | instr2 st2 bci_PUSH_ALTS p |
283 | | PUSH_ALTS_UNLIFTED proto pk -> do |
284 | | ul_bco <- assembleBCO dflags proto |
285 | | (p, st2) <- ptr st (BCOPtrBCO ul_bco) |
286 | | instr2 st2 (push_alts pk) p |
287 | | PUSH_UBX (Left lit) nws |
288 | | -> do (np, st2) <- literal st lit |
289 | | instr3 st2 bci_PUSH_UBX np nws |
290 | | PUSH_UBX (Right aa) nws |
291 | | -> do (np, st2) <- addr st aa |
292 | | instr3 st2 bci_PUSH_UBX np nws |
293 | | |
294 | | PUSH_APPLY_N -> do instr1 st bci_PUSH_APPLY_N |
295 | | PUSH_APPLY_V -> do instr1 st bci_PUSH_APPLY_V |
296 | | PUSH_APPLY_F -> do instr1 st bci_PUSH_APPLY_F |
297 | | PUSH_APPLY_D -> do instr1 st bci_PUSH_APPLY_D |
298 | | PUSH_APPLY_L -> do instr1 st bci_PUSH_APPLY_L |
299 | | PUSH_APPLY_P -> do instr1 st bci_PUSH_APPLY_P |
300 | | PUSH_APPLY_PP -> do instr1 st bci_PUSH_APPLY_PP |
301 | | PUSH_APPLY_PPP -> do instr1 st bci_PUSH_APPLY_PPP |
302 | | PUSH_APPLY_PPPP -> do instr1 st bci_PUSH_APPLY_PPPP |
303 | | PUSH_APPLY_PPPPP -> do instr1 st bci_PUSH_APPLY_PPPPP |
304 | | PUSH_APPLY_PPPPPP -> do instr1 st bci_PUSH_APPLY_PPPPPP |
305 | | |
306 | | SLIDE n by -> instr3 st bci_SLIDE n by |
307 | | ALLOC_AP n -> instr2 st bci_ALLOC_AP n |
308 | | ALLOC_AP_NOUPD n -> instr2 st bci_ALLOC_AP_NOUPD n |
309 | | ALLOC_PAP arity n -> instr3 st bci_ALLOC_PAP arity n |
310 | | MKAP off sz -> instr3 st bci_MKAP off sz |
311 | | MKPAP off sz -> instr3 st bci_MKPAP off sz |
312 | | UNPACK n -> instr2 st bci_UNPACK n |
313 | | PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon |
314 | | instr3 st2 bci_PACK itbl_no sz |
315 | | LABEL _ -> return st |
316 | | TESTLT_I i l -> do (np, st2) <- int st i |
317 | | jumpInstr2 st2 bci_TESTLT_I np (findLabel l) |
318 | | TESTEQ_I i l -> do (np, st2) <- int st i |
319 | | jumpInstr2 st2 bci_TESTEQ_I np (findLabel l) |
320 | | TESTLT_W w l -> do (np, st2) <- word st w |
321 | | jumpInstr2 st2 bci_TESTLT_W np (findLabel l) |
322 | | TESTEQ_W w l -> do (np, st2) <- word st w |
323 | | jumpInstr2 st2 bci_TESTEQ_W np (findLabel l) |
324 | | TESTLT_F f l -> do (np, st2) <- float st f |
325 | | jumpInstr2 st2 bci_TESTLT_F np (findLabel l) |
326 | | TESTEQ_F f l -> do (np, st2) <- float st f |
327 | | jumpInstr2 st2 bci_TESTEQ_F np (findLabel l) |
328 | | TESTLT_D d l -> do (np, st2) <- double st d |
329 | | jumpInstr2 st2 bci_TESTLT_D np (findLabel l) |
330 | | TESTEQ_D d l -> do (np, st2) <- double st d |
331 | | jumpInstr2 st2 bci_TESTEQ_D np (findLabel l) |
332 | | TESTLT_P i l -> jumpInstr2 st bci_TESTLT_P i (findLabel l) |
333 | | TESTEQ_P i l -> jumpInstr2 st bci_TESTEQ_P i (findLabel l) |
334 | | CASEFAIL -> instr1 st bci_CASEFAIL |
335 | | SWIZZLE stkoff n -> instr3 st bci_SWIZZLE stkoff n |
336 | | JMP l -> jumpInstr1 st bci_JMP (findLabel l) |
337 | | ENTER -> instr1 st bci_ENTER |
338 | | RETURN -> instr1 st bci_RETURN |
339 | | RETURN_UBX rep -> instr1 st (return_ubx rep) |
340 | | CCALL off m_addr int -> do (np, st2) <- addr st m_addr |
341 | | instr4 st2 bci_CCALL off np int |
342 | | BRK_FUN array index info -> do |
343 | | (p1, st2) <- ptr st (BCOPtrArray array) |
344 | | (p2, st3) <- ptr st2 (BCOPtrBreakInfo info) |
345 | | instr4 st3 bci_BRK_FUN p1 index p2 |
346 | | |
347 | | instrn :: AsmState -> [Word16] -> IO AsmState |
348 | | instrn st [] = return st |
349 | | instrn (st_i, st_l, st_p) (i:is) |
350 | | = do st_i' <- addToSS st_i i |
351 | | instrn (st_i', st_l, st_p) is |
352 | | |
353 | | jumpInstr1 st i1 i2 |
354 | | | long_jumps = instrn st (largeArgInstr i1 : largeArg i2) |
355 | | | otherwise = instr2 st i1 (fromIntegral i2) |
356 | | |
357 | | jumpInstr2 st i1 i2 i3 |
358 | | | long_jumps = instrn st (largeArgInstr i1 : i2 : largeArg i3) |
359 | | | otherwise = instr3 st i1 i2 (fromIntegral i3) |
360 | | |
361 | | instr1 (st_i0,st_l0,st_p0) i1 |
362 | | = do st_i1 <- addToSS st_i0 i1 |
363 | | return (st_i1,st_l0,st_p0) |
364 | | |
365 | | instr2 (st_i0,st_l0,st_p0) w1 w2 |
366 | | = do st_i1 <- addToSS st_i0 w1 |
367 | | st_i2 <- addToSS st_i1 w2 |
368 | | return (st_i2,st_l0,st_p0) |
369 | | |
370 | | instr3 (st_i0,st_l0,st_p0) w1 w2 w3 |
371 | | = do st_i1 <- addToSS st_i0 w1 |
372 | | st_i2 <- addToSS st_i1 w2 |
373 | | st_i3 <- addToSS st_i2 w3 |
374 | | return (st_i3,st_l0,st_p0) |
375 | | |
376 | | instr4 (st_i0,st_l0,st_p0) w1 w2 w3 w4 |
377 | | = do st_i1 <- addToSS st_i0 w1 |
378 | | st_i2 <- addToSS st_i1 w2 |
379 | | st_i3 <- addToSS st_i2 w3 |
380 | | st_i4 <- addToSS st_i3 w4 |
381 | | return (st_i4,st_l0,st_p0) |
382 | | |
383 | | float (st_i0,st_l0,st_p0) f |
384 | | = do let ws = mkLitF f |
385 | | st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) |
386 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
387 | | |
388 | | double (st_i0,st_l0,st_p0) d |
389 | | = do let ws = mkLitD d |
390 | | st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) |
391 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
392 | | |
393 | | int (st_i0,st_l0,st_p0) i |
394 | | = do let ws = mkLitI i |
395 | | st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) |
396 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
397 | | |
398 | | word (st_i0,st_l0,st_p0) w |
399 | | = do let ws = [w] |
400 | | st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) |
401 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
402 | | |
403 | | int64 (st_i0,st_l0,st_p0) i |
404 | | = do let ws = mkLitI64 i |
405 | | st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) |
406 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
407 | | |
408 | | addr (st_i0,st_l0,st_p0) a |
409 | | = do let ws = mkLitPtr a |
410 | | st_l1 <- addListToSS st_l0 (map BCONPtrWord ws) |
411 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
412 | | |
413 | | litlabel (st_i0,st_l0,st_p0) fs |
414 | | = do st_l1 <- addListToSS st_l0 [BCONPtrLbl fs] |
415 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
416 | | |
417 | | ptr (st_i0,st_l0,st_p0) p |
418 | | = do st_p1 <- addToSS st_p0 p |
419 | | return (sizeSS16 st_p0, (st_i0,st_l0,st_p1)) |
420 | | |
421 | | itbl (st_i0,st_l0,st_p0) dcon |
422 | | = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon)) |
423 | | return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) |
424 | | |
425 | | literal st (MachLabel fs (Just sz) _) |
426 | | | platformOS (targetPlatform dflags) == OSMinGW32 |
427 | | = litlabel st (appendFS fs (mkFastString ('@':show sz))) |
428 | | -- On Windows, stdcall labels have a suffix indicating the no. of |
429 | | -- arg words, e.g. foo@8. testcase: ffi012(ghci) |
430 | | literal st (MachLabel fs _ _) = litlabel st fs |
431 | | literal st (MachWord w) = int st (fromIntegral w) |
432 | | literal st (MachInt j) = int st (fromIntegral j) |
433 | | literal st MachNullAddr = int st 0 |
434 | | literal st (MachFloat r) = float st (fromRational r) |
435 | | literal st (MachDouble r) = double st (fromRational r) |
436 | | literal st (MachChar c) = int st (ord c) |
437 | | literal st (MachInt64 ii) = int64 st (fromIntegral ii) |
438 | | literal st (MachWord64 ii) = int64 st (fromIntegral ii) |
439 | | literal _ other = pprPanic "ByteCodeAsm.literal" (ppr other) |
| 344 | assembleI :: DynFlags |
| 345 | -> BCInstr |
| 346 | -> Assembler () |
| 347 | assembleI dflags i = case i of |
| 348 | STKCHECK n -> emit bci_STKCHECK [Op n] |
| 349 | PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1] |
| 350 | PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2] |
| 351 | PUSH_LLL o1 o2 o3 -> emit bci_PUSH_LLL [SmallOp o1, SmallOp o2, SmallOp o3] |
| 352 | PUSH_G nm -> do p <- ptr (BCOPtrName nm) |
| 353 | emit bci_PUSH_G [SmallOp p] |
| 354 | PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op) |
| 355 | emit bci_PUSH_G [SmallOp p] |
| 356 | PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto |
| 357 | p <- ioptr (liftM BCOPtrBCO ul_bco) |
| 358 | emit bci_PUSH_G [SmallOp p] |
| 359 | PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto |
| 360 | p <- ioptr (liftM BCOPtrBCO ul_bco) |
| 361 | emit bci_PUSH_ALTS [SmallOp p] |
| 362 | PUSH_ALTS_UNLIFTED proto pk |
| 363 | -> do let ul_bco = assembleBCO dflags proto |
| 364 | p <- ioptr (liftM BCOPtrBCO ul_bco) |
| 365 | emit (push_alts pk) [SmallOp p] |
| 366 | PUSH_UBX (Left lit) nws -> do np <- literal lit |
| 367 | emit bci_PUSH_UBX [SmallOp np, SmallOp nws] |
| 368 | PUSH_UBX (Right aa) nws -> do np <- addr aa |
| 369 | emit bci_PUSH_UBX [SmallOp np, SmallOp nws] |
| 370 | |
| 371 | PUSH_APPLY_N -> emit bci_PUSH_APPLY_N [] |
| 372 | PUSH_APPLY_V -> emit bci_PUSH_APPLY_V [] |
| 373 | PUSH_APPLY_F -> emit bci_PUSH_APPLY_F [] |
| 374 | PUSH_APPLY_D -> emit bci_PUSH_APPLY_D [] |
| 375 | PUSH_APPLY_L -> emit bci_PUSH_APPLY_L [] |
| 376 | PUSH_APPLY_P -> emit bci_PUSH_APPLY_P [] |
| 377 | PUSH_APPLY_PP -> emit bci_PUSH_APPLY_PP [] |
| 378 | PUSH_APPLY_PPP -> emit bci_PUSH_APPLY_PPP [] |
| 379 | PUSH_APPLY_PPPP -> emit bci_PUSH_APPLY_PPPP [] |
| 380 | PUSH_APPLY_PPPPP -> emit bci_PUSH_APPLY_PPPPP [] |
| 381 | PUSH_APPLY_PPPPPP -> emit bci_PUSH_APPLY_PPPPPP [] |
| 382 | |
| 383 | SLIDE n by -> emit bci_SLIDE [SmallOp n, SmallOp by] |
| 384 | ALLOC_AP n -> emit bci_ALLOC_AP [SmallOp n] |
| 385 | ALLOC_AP_NOUPD n -> emit bci_ALLOC_AP_NOUPD [SmallOp n] |
| 386 | ALLOC_PAP arity n -> emit bci_ALLOC_PAP [SmallOp arity, SmallOp n] |
| 387 | MKAP off sz -> emit bci_MKAP [SmallOp off, SmallOp sz] |
| 388 | MKPAP off sz -> emit bci_MKPAP [SmallOp off, SmallOp sz] |
| 389 | UNPACK n -> emit bci_UNPACK [SmallOp n] |
| 390 | PACK dcon sz -> do itbl_no <- lit [BCONPtrItbl (getName dcon)] |
| 391 | emit bci_PACK [SmallOp itbl_no, SmallOp sz] |
| 392 | LABEL lbl -> label lbl |
| 393 | TESTLT_I i l -> do np <- int i |
| 394 | emit bci_TESTLT_I [SmallOp np, LabelOp l] |
| 395 | TESTEQ_I i l -> do np <- int i |
| 396 | emit bci_TESTEQ_I [SmallOp np, LabelOp l] |
| 397 | TESTLT_W w l -> do np <- word w |
| 398 | emit bci_TESTLT_W [SmallOp np, LabelOp l] |
| 399 | TESTEQ_W w l -> do np <- word w |
| 400 | emit bci_TESTEQ_W [SmallOp np, LabelOp l] |
| 401 | TESTLT_F f l -> do np <- float f |
| 402 | emit bci_TESTLT_F [SmallOp np, LabelOp l] |
| 403 | TESTEQ_F f l -> do np <- float f |
| 404 | emit bci_TESTEQ_F [SmallOp np, LabelOp l] |
| 405 | TESTLT_D d l -> do np <- double d |
| 406 | emit bci_TESTLT_D [SmallOp np, LabelOp l] |
| 407 | TESTEQ_D d l -> do np <- double d |
| 408 | emit bci_TESTEQ_D [SmallOp np, LabelOp l] |
| 409 | TESTLT_P i l -> emit bci_TESTLT_P [SmallOp i, LabelOp l] |
| 410 | TESTEQ_P i l -> emit bci_TESTEQ_P [SmallOp i, LabelOp l] |
| 411 | CASEFAIL -> emit bci_CASEFAIL [] |
| 412 | SWIZZLE stkoff n -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n] |
| 413 | JMP l -> emit bci_JMP [LabelOp l] |
| 414 | ENTER -> emit bci_ENTER [] |
| 415 | RETURN -> emit bci_RETURN [] |
| 416 | RETURN_UBX rep -> emit (return_ubx rep) [] |
| 417 | CCALL off m_addr i -> do np <- addr m_addr |
| 418 | emit bci_CCALL [SmallOp off, SmallOp np, SmallOp i] |
| 419 | BRK_FUN array index info -> do p1 <- ptr (BCOPtrArray array) |
| 420 | p2 <- ptr (BCOPtrBreakInfo info) |
| 421 | emit bci_BRK_FUN [SmallOp p1, SmallOp index, SmallOp p2] |
| 422 | |
| 423 | where |
| 424 | literal (MachLabel fs (Just sz) _) |
| 425 | | platformOS (targetPlatform dflags) == OSMinGW32 |
| 426 | = litlabel (appendFS fs (mkFastString ('@':show sz))) |
| 427 | -- On Windows, stdcall labels have a suffix indicating the no. of |
| 428 | -- arg words, e.g. foo@8. testcase: ffi012(ghci) |
| 429 | literal (MachLabel fs _ _) = litlabel fs |
| 430 | literal (MachWord w) = int (fromIntegral w) |
| 431 | literal (MachInt j) = int (fromIntegral j) |
| 432 | literal MachNullAddr = int 0 |
| 433 | literal (MachFloat r) = float (fromRational r) |
| 434 | literal (MachDouble r) = double (fromRational r) |
| 435 | literal (MachChar c) = int (ord c) |
| 436 | literal (MachInt64 ii) = int64 (fromIntegral ii) |
| 437 | literal (MachWord64 ii) = int64 (fromIntegral ii) |
| 438 | literal other = pprPanic "ByteCodeAsm.literal" (ppr other) |
| 439 | |
| 440 | litlabel fs = lit [BCONPtrLbl fs] |
| 441 | addr = words . mkLitPtr |
| 442 | float = words . mkLitF |
| 443 | double = words . mkLitD |
| 444 | int = words . mkLitI |
| 445 | int64 = words . mkLitI64 |
| 446 | words ws = lit (map BCONPtrWord ws) |
| 447 | word w = words [w] |